File Coverage

blib/lib/Complete/Sah.pm
Criterion Covered Total %
statement 188 231 81.3
branch 84 120 70.0
condition 60 100 60.0
subroutine 9 9 100.0
pod 1 1 100.0
total 342 461 74.1


line stmt bran cond sub pod time code
1             package Complete::Sah;
2              
3 1     1   113731 use 5.010001;
  1         16  
4 1     1   18 use strict;
  1         3  
  1         25  
5 1     1   4 use warnings;
  1         2  
  1         34  
6 1     1   2523 use Log::ger;
  1         52  
  1         4  
7              
8 1     1   721 use Complete::Common qw(:all);
  1         444  
  1         142  
9 1     1   600 use Complete::Util qw(combine_answers complete_array_elem hashify_answer);
  1         6250  
  1         76  
10 1     1   7 use Exporter qw(import);
  1         2  
  1         344  
11              
12             our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
13             our $DATE = '2023-05-26'; # DATE
14             our $DIST = 'Complete-Sah'; # DIST
15             our $VERSION = '0.013'; # VERSION
16              
17             our %SPEC;
18             our @EXPORT_OK = qw(complete_from_schema);
19              
20             $SPEC{':package'} = {
21             v => 1.1,
22             summary => 'Sah-related completion routines',
23             };
24              
25             $SPEC{complete_from_schema} = {
26             v => 1.1,
27             summary => 'Complete a value from schema',
28             description => <<'_',
29              
30             Employ some heuristics to complete a value from Sah schema. For example, if
31             schema is `[str => in => [qw/new open resolved rejected/]]`, then we can
32             complete from the `in` clause. Or for something like `[int => between => [1,
33             20]]` we can complete using values from 1 to 20.
34              
35             Tip: If you want to give summary for each entry in `in` clause, you can use the
36             `x.in.summaries` attribute, example:
37              
38             # schema
39             ['str', {
40             in => ['b', 'g'],
41             'x.in.summaries' => ['Male/boy', 'Female/girl'],
42             }]
43              
44             _
45             args => {
46             schema => {
47             schema => ['any*', of=>['str*', 'array*']], # XXX sah::schema
48             description => <<'_',
49              
50             Will be normalized, unless when `schema_is_normalized` is set to true, in which
51             case schema must already be normalized.
52              
53             _
54             req => 1,
55             },
56             schema_is_normalized => {
57             schema => 'bool',
58             default => 0,
59             },
60             word => {
61             schema => [str => default => ''],
62             req => 1,
63             },
64             },
65             result_naked => 1,
66             };
67             sub complete_from_schema {
68 43     43 1 136029 my %args = @_;
69 43         86 my $sch = $args{schema};
70 43   50     115 my $word = $args{word} // "";
71              
72 43 100       93 unless ($args{schema_is_normalized}) {
73 42         1653 require Data::Sah::Normalize;
74 42         1826 $sch = Data::Sah::Normalize::normalize_schema($sch);
75             }
76              
77 43         2839 my $fres;
78 43         134 log_trace("[compsah] entering complete_from_schema, word=<%s>, schema=%s", $word, $sch);
79              
80 43         118 my ($type, $clset) = @{$sch};
  43         107  
81              
82             # schema might be based on other schemas, if that is the case, let's try to
83             # look at Sah::SchemaR::* module to quickly find the base type
84 42 100       204 unless ($type =~ /\A(all|any|array|bool|buf|cistr|code|date|duration|float|hash|int|num|obj|re|str|undef)\z/) {
85 1     1   8 no strict 'refs'; ## no critic: TestingAndDebugging::ProhibitNoStrict
  1         2  
  1         2260  
86 3         9 my $pkg = "Sah::SchemaR::$type";
87 3         27 (my $pkg_pm = "$pkg.pm") =~ s!::!/!g;
88 3         6 eval { require $pkg_pm; 1 };
  3         3165  
  2         119  
89 3 100       15 if ($@) {
90 1         8 log_trace("[compsah] couldn't load schema module %s: %s, skipped", $pkg, $@);
91 1         24 goto RETURN_RES;
92             }
93 2         3 my $rsch = ${"$pkg\::rschema"};
  2         9  
94 2 50       8 $type = ref $rsch eq 'ARRAY' ? $rsch->[0] : $rsch->{type}; # support older (v.009-) version of Data::Sah::Resolve result
95 2 50       4 my $clsets = ref $rsch eq 'ARRAY' ? $rsch->[1] : $rsch->{'clsets_after_type.alt.merge.merged'};
96             # let's just merge everything, for quick checking of clause
97 2         4 my $merged_clset = {};
98 2         12 for my $clset0 (@{ $clsets }) {
  2         4  
99 2         8 for (keys %$clset0) {
100 9         18 $merged_clset->{$_} = $clset0->{$_};
101             }
102             }
103 2         3 $clset = $merged_clset;
104 2         12 log_trace("[compsah] retrieving schema from module %s, base type=%s", $pkg, $type);
105             }
106              
107 41         110 my $static;
108             my $words;
109 41         0 my $summaries;
110 41         71 eval {
111 41 50       102 if (my $xcomp = $clset->{'x.completion'}) {
112 0         0 require Module::Installed::Tiny;
113 0         0 my $comp;
114 0 0       0 if (ref($xcomp) eq 'CODE') {
115 0         0 $comp = $xcomp;
116             } else {
117 0         0 my ($submod, $xcargs);
118 0 0       0 if (ref($xcomp) eq 'ARRAY') {
119 0         0 $submod = $xcomp->[0];
120 0         0 $xcargs = $xcomp->[1];
121             } else {
122 0         0 $submod = $xcomp;
123 0         0 $xcargs = {};
124             }
125 0         0 my $mod = "Perinci::Sub::XCompletion::$submod";
126 0 0       0 if (Module::Installed::Tiny::module_installed($mod)) {
127 0         0 log_trace("[compsah] loading module %s ...", $mod);
128 0         0 my $mod_pm = $mod; $mod_pm =~ s!::!/!g; $mod_pm .= ".pm";
  0         0  
  0         0  
129 0         0 require $mod_pm;
130 0         0 my $fref = \&{"$mod\::gen_completion"};
  0         0  
131 0         0 log_trace("[compsah] invoking %s\::gen_completion(%s) ...", $mod, $xcargs);
132 0         0 $comp = $fref->(%$xcargs);
133             } else {
134 0         0 log_trace("[compsah] module %s is not installed, skipped", $mod);
135             }
136             }
137 0 0       0 if ($comp) {
138             # create a validator, to be used by the completion routine
139             #require Data::Sah;
140             #my $vdr = Data::Sah::gen_validator($sch, {schema_is_normalized=>1});
141              
142             my %cargs = (
143 0   0     0 %{$args{extras} // {}},
144             word=>$word, arg=>$args{arg}, args=>$args{args},
145             #_schema_validator => $vdr,
146 0         0 _schema => $sch,
147             );
148 0         0 log_trace("[compsah] using arg completion routine from schema's 'x.completion' attribute with args (%s)", \%cargs);
149 0         0 $fres = $comp->(%cargs);
150 0         0 return; # from eval
151             }
152             }
153              
154 41 100 100     112 if ($clset->{is} && !ref($clset->{is})) {
155 1         4 log_trace("[compsah] adding completion from schema's 'is' clause");
156 1         5 push @$words, $clset->{is};
157 1         2 push @$summaries, undef;
158 1         2 $static++;
159 1         2 return; # from eval. there should not be any other value
160             }
161 40 100       82 if ($clset->{in}) {
162 3         18 log_trace("[compsah] adding completion from schema's 'in' clause");
163 3         11 for my $i (0..$#{ $clset->{in} }) {
  3         13  
164 4 50       10 next if ref $clset->{in}[$i];
165 4         11 push @$words , $clset->{in}[$i];
166 4 50       12 push @$summaries, $clset->{'x.in.summaries'} ? $clset->{'x.in.summaries'}[$i] : undef;
167             }
168 3         8 $static++;
169 3         5 return; # from eval. there should not be any other value
170             }
171 37 100       74 if ($clset->{'examples'}) {
172 3         9 log_trace("[compsah] adding completion from schema's 'examples' clause");
173 3         9 for my $eg (@{ $clset->{'examples'} }) {
  3         8  
174 7 100       17 if (ref $eg eq 'HASH') {
175 6 100 100     24 next unless !exists($eg->{valid}) || $eg->{valid};
176 3 100       9 next unless defined $eg->{value};
177 1 50       3 next if ref $eg->{value};
178 1         2 push @$words, $eg->{value};
179 1         3 push @$summaries, $eg->{summary};
180             } else {
181 1 50       3 next unless defined $eg;
182 1 50       3 next if ref $eg;
183 1         3 push @$words, $eg;
184 1         3 push @$summaries, undef;
185             }
186             }
187             #$static++;
188             #return; # from eval. there should not be any other value
189             }
190 37 100       78 if ($type eq 'any') {
191             # because currently Data::Sah::Normalize doesn't recursively
192             # normalize schemas in 'of' clauses, etc.
193 2         9 require Data::Sah::Normalize;
194 2 50 33     8 if ($clset->{of} && @{ $clset->{of} }) {
  2         8  
195              
196             $fres = combine_answers(
197 4         17 grep { defined } map {
198 4         63 complete_from_schema(schema=>$_, word => $word)
199 2         3 } @{ $clset->{of} }
  2         8  
200             );
201 2         373 goto RETURN_RES; # directly return result
202             }
203             }
204 35 50       73 if ($type eq 'bool') {
205 0         0 log_trace("[compsah] adding completion from possible values of bool");
206 0         0 push @$words, 0, 1;
207 0         0 push @$summaries, undef, undef;
208 0         0 $static++;
209 0         0 return; # from eval
210             }
211 35 100       64 if ($type eq 'int') {
212 21         30 my $limit = 100;
213 21 100 66     326 if ($clset->{between} &&
    100 66        
    100 100        
    100 100        
    100 100        
    100 66        
    100 100        
      66        
      66        
      66        
      100        
214             $clset->{between}[0] - $clset->{between}[0] <= $limit) {
215 1         5 log_trace("[compsah] adding completion from schema's 'between' clause");
216 1         9 for ($clset->{between}[0] .. $clset->{between}[1]) {
217 13         20 push @$words, $_;
218 13         19 push @$summaries, undef;
219             }
220 1         2 $static++;
221             } elsif ($clset->{xbetween} &&
222             $clset->{xbetween}[0] - $clset->{xbetween}[0] <= $limit) {
223 1         5 log_trace("[compsah] adding completion from schema's 'xbetween' clause");
224 1         9 for ($clset->{xbetween}[0]+1 .. $clset->{xbetween}[1]-1) {
225 11         17 push @$words, $_;
226 11         15 push @$summaries, undef;
227             }
228 1         17 $static++;
229             } elsif (defined($clset->{min}) && defined($clset->{max}) &&
230             $clset->{max}-$clset->{min} <= $limit) {
231 2         8 log_trace("[compsah] adding completion from schema's 'min' & 'max' clauses");
232 2         13 for ($clset->{min} .. $clset->{max}) {
233 20         26 push @$words, $_;
234 20         53 push @$summaries, undef;
235             }
236 2         5 $static++;
237             } elsif (defined($clset->{min}) && defined($clset->{xmax}) &&
238             $clset->{xmax}-$clset->{min} <= $limit) {
239 1         4 log_trace("[compsah] adding completion from schema's 'min' & 'xmax' clauses");
240 1         6 for ($clset->{min} .. $clset->{xmax}-1) {
241 12         16 push @$words, $_;
242 12         21 push @$summaries, undef;
243             }
244 1         2 $static++;
245             } elsif (defined($clset->{xmin}) && defined($clset->{max}) &&
246             $clset->{max}-$clset->{xmin} <= $limit) {
247 1         5 log_trace("[compsah] adding completion from schema's 'xmin' & 'max' clauses");
248 1         7 for ($clset->{xmin}+1 .. $clset->{max}) {
249 12         17 push @$words, $_;
250 12         45 push @$summaries, undef;
251             }
252 1         3 $static++;
253             } elsif (defined($clset->{xmin}) && defined($clset->{xmax}) &&
254             $clset->{xmax}-$clset->{xmin} <= $limit) {
255 1         5 log_trace("[compsah] adding completion from schema's 'xmin' & 'xmax' clauses");
256 1         7 for ($clset->{xmin}+1 .. $clset->{xmax}-1) {
257 11         17 push @$words, $_;
258 11         16 push @$summaries, undef;
259             }
260 1         9 $static++;
261             } elsif (length($word) && $word !~ /\A-?\d*\z/) {
262 1         8 log_trace("[compsah] word not an int");
263 1         3 $words = [];
264 1         2 $summaries = [];
265             } else {
266             # do a digit by digit completion
267 13         23 $words = [];
268 13         21 $summaries = [];
269 13         27 for my $sign ("", "-") {
270 26         41 for ("", 0..9) {
271 286         537 my $i = $sign . $word . $_;
272 286 100       474 next unless length $i;
273 282 100       745 next unless $i =~ /\A-?\d+\z/;
274 245 100       397 next if $i eq '-0';
275 240 100       450 next if $i =~ /\A-?0\d/;
276             next if $clset->{between} &&
277             ($i < $clset->{between}[0] ||
278 220 0 0     377 $i > $clset->{between}[1]);
      33        
279             next if $clset->{xbetween} &&
280             ($i <= $clset->{xbetween}[0] ||
281 220 0 0     334 $i >= $clset->{xbetween}[1]);
      33        
282 220 100 100     579 next if defined($clset->{min} ) && $i < $clset->{min};
283 156 50 33     251 next if defined($clset->{xmin}) && $i <= $clset->{xmin};
284 156 100 100     324 next if defined($clset->{max} ) && $i > $clset->{max};
285 136 50 33     242 next if defined($clset->{xmin}) && $i >= $clset->{xmax};
286 136         221 push @$words, $i;
287 136         249 push @$summaries, undef;
288             }
289             }
290             }
291 21         42 return; # from eval
292             }
293 14 100       35 if ($type eq 'float') {
294 11 100 100     80 if (length($word) && $word !~ /\A-?\d*(\.\d*)?\z/) {
295 1         5 log_trace("[compsah] word not a float");
296 1         3 $words = [];
297 1         2 $summaries = [];
298             } else {
299 10         21 $words = [];
300 10         16 $summaries = [];
301 10         18 for my $sig ("", "-") {
302 20         41 for ("", 0..9,
303             ".0",".1",".2",".3",".4",".5",".6",".7",".8",".9") {
304 420         711 my $f = $sig . $word . $_;
305 420 100       680 next unless length $f;
306 418 100       1128 next unless $f =~ /\A-?\d+(\.\d+)?\z/;
307 291 100       500 next if $f eq '-0';
308 286 100       605 next if $f =~ /\A-?0\d\z/;
309             next if $clset->{between} &&
310             ($f < $clset->{between}[0] ||
311 236 0 0     427 $f > $clset->{between}[1]);
      33        
312             next if $clset->{xbetween} &&
313             ($f <= $clset->{xbetween}[0] ||
314 236 0 0     358 $f >= $clset->{xbetween}[1]);
      33        
315 236 100 100     596 next if defined($clset->{min} ) && $f < $clset->{min};
316 189 50 33     348 next if defined($clset->{xmin}) && $f <= $clset->{xmin};
317 189 100 100     349 next if defined($clset->{max} ) && $f > $clset->{max};
318 186 50 33     340 next if defined($clset->{xmin}) && $f >= $clset->{xmax};
319 186         306 push @$words, $f;
320 186         314 push @$summaries, undef;
321             }
322             }
323 546         721 my @orders = sort { $words->[$a] cmp $words->[$b] }
324 10         20 0..$#{$words};
  10         64  
325 10         28 my $words = [map {$words->[$_] } @orders];
  186         277  
326 10         52 my $summaries = [map {$summaries->[$_]} @orders];
  186         288  
327             }
328 11         32 return; # from eval
329             }
330             }; # eval
331 39 50       78 log_trace("[compsah] complete_from_schema died: %s", $@) if $@;
332              
333 39         60 my $replace_map;
334             GET_REPLACE_MAP:
335             {
336 39 50       59 last unless $clset->{prefilters};
  39         90  
337             # TODO: make replace_map in Complete::Util equivalent as
338             # Str::replace_map's map.
339 0         0 for my $entry (@{ $clset->{prefilters} }) {
  0         0  
340 0 0       0 next unless ref $entry eq 'ARRAY';
341 0 0       0 next unless $entry->[0] eq 'Str::replace_map';
342 0         0 $replace_map = {};
343 0         0 for my $k (keys %{ $entry->[1]{map} }) {
  0         0  
344 0         0 my $v = $entry->[1]{map}{$k};
345 0         0 $replace_map->{$v} = [$k];
346             }
347 0         0 last;
348             }
349             }
350              
351 39 100       84 goto RETURN_RES unless $words;
352 37 100 66     133 $fres = hashify_answer(
353             complete_array_elem(
354             array=>$words,
355             summaries=>$summaries,
356             word=>$word,
357             (replace_map => $replace_map) x !!$replace_map,
358             ),
359             {static=>$static && $word eq '' ? 1:0},
360             );
361              
362 42         9744 RETURN_RES:
363             log_trace("[compsah] leaving complete_from_schema, result=%s", $fres);
364 42         615 $fres;
365             }
366              
367             1;
368             # ABSTRACT: Sah-related completion routines
369              
370             __END__
371              
372             =pod
373              
374             =encoding UTF-8
375              
376             =head1 NAME
377              
378             Complete::Sah - Sah-related completion routines
379              
380             =head1 VERSION
381              
382             This document describes version 0.013 of Complete::Sah (from Perl distribution Complete-Sah), released on 2023-05-26.
383              
384             =head1 SYNOPSIS
385              
386             use Complete::Sah qw(complete_from_schema);
387             my $res = complete_from_schema(word => 'a', schema=>[str => {in=>[qw/apple apricot banana/]}]);
388             # -> {words=>['apple', 'apricot'], static=>0}
389              
390             =head1 FUNCTIONS
391              
392              
393             =head2 complete_from_schema
394              
395             Usage:
396              
397             complete_from_schema(%args) -> any
398              
399             Complete a value from schema.
400              
401             Employ some heuristics to complete a value from Sah schema. For example, if
402             schema is C<< [str =E<gt> in =E<gt> [qw/new open resolved rejected/]] >>, then we can
403             complete from the C<in> clause. Or for something like C<< [int =E<gt> between =E<gt> [1,
404             20]] >> we can complete using values from 1 to 20.
405              
406             Tip: If you want to give summary for each entry in C<in> clause, you can use the
407             C<x.in.summaries> attribute, example:
408              
409             # schema
410             ['str', {
411             in => ['b', 'g'],
412             'x.in.summaries' => ['Male/boy', 'Female/girl'],
413             }]
414              
415             This function is not exported by default, but exportable.
416              
417             Arguments ('*' denotes required arguments):
418              
419             =over 4
420              
421             =item * B<schema>* => I<str|array>
422              
423             Will be normalized, unless when C<schema_is_normalized> is set to true, in which
424             case schema must already be normalized.
425              
426             =item * B<schema_is_normalized> => I<bool> (default: 0)
427              
428             (No description)
429              
430             =item * B<word>* => I<str> (default: "")
431              
432             (No description)
433              
434              
435             =back
436              
437             Return value: (any)
438              
439             =head1 HOMEPAGE
440              
441             Please visit the project's homepage at L<https://metacpan.org/release/Complete-Sah>.
442              
443             =head1 SOURCE
444              
445             Source repository is at L<https://github.com/perlancar/perl-Complete-Sah>.
446              
447             =head1 AUTHOR
448              
449             perlancar <perlancar@cpan.org>
450              
451             =head1 CONTRIBUTING
452              
453              
454             To contribute, you can send patches by email/via RT, or send pull requests on
455             GitHub.
456              
457             Most of the time, you don't need to build the distribution yourself. You can
458             simply modify the code, then test via:
459              
460             % prove -l
461              
462             If you want to build the distribution (e.g. to try to install it locally on your
463             system), you can install L<Dist::Zilla>,
464             L<Dist::Zilla::PluginBundle::Author::PERLANCAR>,
465             L<Pod::Weaver::PluginBundle::Author::PERLANCAR>, and sometimes one or two other
466             Dist::Zilla- and/or Pod::Weaver plugins. Any additional steps required beyond
467             that are considered a bug and can be reported to me.
468              
469             =head1 COPYRIGHT AND LICENSE
470              
471             This software is copyright (c) 2023, 2020, 2019 by perlancar <perlancar@cpan.org>.
472              
473             This is free software; you can redistribute it and/or modify it under
474             the same terms as the Perl 5 programming language system itself.
475              
476             =head1 BUGS
477              
478             Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Complete-Sah>
479              
480             When submitting a bug or request, please include a test-file or a
481             patch to an existing test-file that illustrates the bug or desired
482             feature.
483              
484             =cut