File Coverage

blib/lib/App/Easer/V2.pm
Criterion Covered Total %
statement 716 823 87.0
branch 174 284 61.2
condition 58 117 49.5
subroutine 100 115 86.9
pod 4 4 100.0
total 1052 1343 78.3


line stmt bran cond sub pod time code
1             package App::Easer::V2;
2 17     17   188133 use v5.24;
  17         87  
3 17     17   91 use warnings;
  17         52  
  17         644  
4 17     17   612 use experimental qw< signatures >;
  17         3618  
  17         144  
5 17     17   2046 no warnings qw< experimental::signatures >;
  17         33  
  17         1188  
6             { our $VERSION = '2.006' }
7 17     17   117 use Carp;
  17         34  
  17         1051  
8              
9 17     17   1599 use parent 'Exporter';
  17         955  
  17         123  
10             our @EXPORT_OK = qw< appeaser_api d dd run >;
11              
12             # repeated stuff to ease direct usage and fatpack-like inclusion
13 2     2 1 2643 sub appeaser_api { __PACKAGE__ =~ s{.*::}{}rmxs }
14 0     0 1 0 sub d { warn dd(@_) }
15              
16 0     0 1 0 sub dd (@stuff) {
  0         0  
  0         0  
17 17     17   3203 no warnings;
  17         43  
  17         5688  
18 0         0 require Data::Dumper;
19 0         0 local $Data::Dumper::Indent = 1;
20 0 0 0     0 Data::Dumper::Dumper(
    0          
21             @stuff == 0 ? []
22             : (ref($stuff[0]) || @stuff % 2) ? \@stuff
23             : {@stuff}
24             );
25             } ## end sub dd (@stuff)
26              
27 80     80 1 350777 sub run ($app, @args) {
  80         164  
  80         237  
  80         121  
28 80         162 my $class = 'App::Easer::V2::Command';
29 80 0       710 my $instance =
    50          
30             ref($app) eq 'HASH' ? $class->new($app)
31             : ref($app) eq 'ARRAY' ? $class->instantiate($app->@*)
32             : $class->instantiate($app);
33 80         287 return $instance->run(@args);
34             } ## end sub run
35              
36 8     8   4631 sub import ($package, @args) {
  8         24  
  8         14  
  8         12  
37 8         21 my $target = caller;
38 8         33 my @args_for_exporter;
39 8         14 our %registered;
40 8         21 while (@args) {
41 14         30 my $request = shift @args;
42 14 100       49 if ($request eq '-command') {
    50          
    50          
    100          
43 6         12 $registered{$target} = 1;
44 17     17   160 no strict 'refs';
  17         30  
  17         1674  
45 6         8 push @{$target . '::ISA'}, 'App::Easer::V2::Command';
  6         75  
46             }
47             elsif ($request eq '-inherit') {
48 17     17   123 no strict 'refs';
  17         31  
  17         2027  
49 0         0 push @{$target . '::ISA'}, 'App::Easer::V2::Command';
  0         0  
50             }
51             elsif ($request eq '-register') {
52 0         0 $registered{$target} = 1;
53             }
54             elsif ($request eq '-spec') {
55 4 50       11 Carp::croak "no specification provided"
56             unless @args;
57 4 50       11 Carp::croak "invalid specification provided"
58             unless ref($args[0]) eq 'HASH';
59 17     17   110 no strict 'refs';
  17         56  
  17         573  
60 17     17   102 no warnings 'once';
  17         82  
  17         2719  
61 4         6 ${$target . '::app_easer_spec'} = shift @args;
  4         21  
62             } ## end elsif ($request eq '-spec')
63 4         10 else { push @args_for_exporter, $request }
64             } ## end while (@args)
65 8         368647 $package->export_to_level(1, $package, @args_for_exporter);
66             } ## end sub import
67              
68             package App::Easer::V2::Command;
69 17     17   123 use Scalar::Util 'blessed';
  17         31  
  17         906  
70 17     17   109 use List::Util 'any';
  17         34  
  17         1965  
71 17     17   8656 use English '-no_match_vars';
  17         32521  
  17         99  
72              
73             # some stuff can be managed via a hash reference kept in a "slot",
74             # allowing for overriding should be easy either with re-defining the
75             # "slot" method, or overriding the sub-method relying on it. The name of
76             # the slot is the same as the name of the actual package that $self is
77             # blessed into.
78 5861   50 5861   7199 sub slot ($self) { return $self->{blessed($self)} //= {} }
  5861         7227  
  5861         6968  
  5861         23569  
79              
80             # This is a poor man's way to easily define attributes in a single line
81             # Corinna will be a blessing eventually
82 5861     5861   33691 sub _rwn ($self, $name, @newval) {
  5861         7340  
  5861         7772  
  5861         7139  
  5861         6652  
83 5861         9706 my $vref = \$self->slot->{$name};
84 5861 100       12901 $$vref = $newval[0] if @newval;
85 5861         16827 return $$vref;
86             }
87              
88 2771     2771   3533 sub _rw ($s, @n) { $s->_rwn((caller(1))[3] =~ s{.*::}{}rmxs, @n) }
  2771         3486  
  2771         3594  
  2771         3596  
  2771         17169  
89              
90 2171     2171   2862 sub _rwa ($self, @n) {
  2171         2865  
  2171         3087  
  2171         2732  
91 2171         17101 my $aref = $self->_rwn((caller(1))[3] =~ s{.*::}{}rmxs, @n);
92 2171 50       6390 Carp::confess() unless defined $aref;
93 2171         5374 return $aref->@*;
94             }
95              
96 134     134   184 sub _rwad ($self, @n) {
  134         208  
  134         174  
  134         185  
97 134   50     1081 my $aref = $self->_rwn((caller(1))[3] =~ s{.*::}{}rmxs, @n) // [];
98 134 50       648 return wantarray ? $aref->@* : [$aref->@*];
99             }
100              
101             # these "attributes" would point to stuff that is normally "scalar" and
102             # used as specification overall. It can be overridden but probably it's
103             # just easier to stick in a hash inside the slot. We don't want to put
104             # executables here, though - overriding should be the guiding principle
105             # in this case.
106 134     134   215 sub aliases ($self, @r) {
  134         176  
  134         180  
  134         160  
107 134 100       294 if (my @aliases = $self->_rwad(@r)) { return @aliases }
  111         631  
108 23 100       63 if (defined(my $name = $self->_rwn('name'))) { return $name }
  22         74  
109 1         31 return;
110             }
111 248     248   379 sub allow_residual_options ($self, @r) { $self->_rw(@r) }
  248         346  
  248         344  
  248         307  
  248         504  
112 108     108   146 sub auto_environment ($self, @r) { $self->_rw(@r) }
  108         172  
  108         154  
  108         136  
  108         201  
113 155     155   220 sub call_name ($self, @r) { $self->_rw(@r) }
  155         239  
  155         232  
  155         208  
  155         324  
114 402     402   518 sub children ($self, @r) { $self->_rwa(@r) }
  402         520  
  402         520  
  402         526  
  402         781  
115 804     804   1226 sub children_prefixes ($self, @r) { $self->_rwa(@r) }
  804         1193  
  804         1010  
  804         1032  
  804         1564  
116 52     52   83 sub default_child ($self, @r) { $self->_rw(@r) }
  52         81  
  52         70  
  52         65  
  52         88  
117 18     18   40 sub description ($self, @r) { $self->_rw(@r) }
  18         31  
  18         40  
  18         27  
  18         47  
118 100     100   114 sub environment_prefix ($self, @r) { $self->_rw(@r) }
  100         120  
  100         139  
  100         120  
  100         162  
119 79     79   127 sub execution_reason ($self, @r) { $self->_rw(@r) }
  79         122  
  79         165  
  79         145  
  79         164  
120 402     402   568 sub force_auto_children ($self, @r) { $self->_rw(@r) }
  402         534  
  402         502  
  402         510  
  402         720  
121 4     4   10 sub fallback_to ($self, @r) { $self->_rw(@r) }
  4         9  
  4         16  
  4         7  
  4         11  
122 161     161   263 sub hashy_class ($self, @r) { $self->_rw(@r) }
  161         220  
  161         201  
  161         191  
  161         309  
123 28     28   55 sub help ($self, @r) { $self->_rw(@r) }
  28         77  
  28         43  
  28         39  
  28         77  
124 24     24   71 sub help_channel ($slf, @r) { $slf->_rw(@r) }
  24         71  
  24         35  
  24         40  
  24         50  
125 34   100 34   427 sub name ($s, @r) { $s->_rw(@r) // ($s->aliases)[0] // '**no name**' }
  34   100     53  
  34         43  
  34         46  
  34         97  
126 148     148   214 sub params_validate ($self, @r) { $self->_rw(@r) }
  148         212  
  148         199  
  148         213  
  148         338  
127 527     527   684 sub parent ($self, @r) { $self->_rw(@r) }
  527         713  
  527         675  
  527         635  
  527         991  
128 337     337   653 sub residual_args ($self, @r) { $self->_rwa(@r) }
  337         520  
  337         448  
  337         399  
  337         601  
129 148     148   223 sub sources ($self, @r) { $self->_rwa(@r) }
  148         208  
  148         208  
  148         179  
  148         360  
130              
131 132     132   174 sub supports ($self, $what) {
  132         253  
  132         210  
  132         195  
132 132     146   674 any { $_ eq $what } $self->aliases;
  146         1115  
133             }
134              
135 480     480   657 sub options ($self, @r) {
  480         664  
  480         587  
  480         600  
136 480         949 return map { $self->resolve_options($_) } $self->_rwa(@r);
  969         1756  
137             }
138              
139 969     969   1170 sub resolve_options ($self, $spec) {
  969         1266  
  969         1157  
  969         1122  
140 969 100       2660 return $spec if ref($spec) eq 'HASH';
141 18 50       52 $spec = [inherit_options => $spec] unless ref $spec;
142 18 50       43 Carp::confess("invalid spec $spec") unless ref($spec) eq 'ARRAY';
143 18         40 my ($method_name, @names) = $spec->@*;
144 18 50       58 my $method = $self->can($method_name)
145             or Carp::confess("cannot find method $method_name in $self");
146 18         37 return $self->$method(@names);
147             } ## end sub resolve_options
148              
149 18     18   22 sub inherit_options ($self, @names) {
  18         23  
  18         58  
  18         24  
150 18         30 my %got;
151             map {
152 18         31 my @options;
  18         23  
153 18 50       39 if ($_ eq '+parent') {
154 18   100     37 @options = grep { $_->{transmit} // 0 } $self->parent->options;
  108         238  
155             }
156             else {
157 0         0 my $namerx = qr{\A(?:$_)\z};
158 0         0 my $ancestor = $self->parent;
159 0         0 while ($ancestor) {
160             push @options, my @pass = # FIXME something's strange here
161             grep {
162 0         0 my $name = $self->name_for_option($_);
  0         0  
163             (!$_->{transmit_exact})
164             && $name =~ m{$namerx}
165 0 0 0     0 && !$got{$name};
166             } $ancestor->options;
167 0         0 $ancestor = $ancestor->parent;
168             } ## end while ($ancestor)
169             } ## end else [ if ($_ eq '+parent') ]
170 18         35 map { +{transmit => 1, $_->%*, inherited => 1} } @options;
  90         354  
171             } @names;
172             } ## end sub inherit_options
173              
174 277     277   441 sub new ($pkg, @args) {
  277         417  
  277         740  
  277         413  
175 17     17   35171 my $pkg_spec = do { no strict 'refs'; ${$pkg . '::app_easer_spec'} };
  17         296  
  17         137518  
  277         363  
  277         352  
  277         1149  
176 277 100 100     4612 my $slot = {
      66        
177             aliases => [],
178             allow_residual_options => 0,
179             auto_environment => 0,
180             children => [],
181             children_prefixes => [$pkg . '::Cmd'],
182             default_child => 'help',
183             environment_prefix => '',
184             fallback_to => undef,
185             force_auto_children => undef,
186             hashy_class => __PACKAGE__,
187             help_channel => '-STDOUT:encoding(UTF-8)',
188             options => [],
189             params_validate => undef,
190             sources => [qw< +CmdLine +Environment +Parent=70 +Default=100 >],
191             ($pkg_spec // {})->%*,
192             (@args && ref $args[0] ? $args[0]->%* : @args),
193             };
194 277         1035 my $self = bless {$pkg => $slot}, $pkg;
195 277         677 return $self;
196             } ## end sub new
197              
198 612     612   937 sub merge_hashes ($self, @hrefs) {
  612         814  
  612         876  
  612         715  
199 612         871 my (%retval, %is_overridable);
200 612         1088 for my $href (@hrefs) {
201 1585         3341 for my $src_key (keys $href->%*) {
202 953         1268 my $dst_key = $src_key;
203 953         1125 my $this_overridable = 0;
204             $retval{$dst_key} = $href->{$src_key}
205 953 100 66     3331 if $is_overridable{$dst_key} || !exists($retval{$dst_key});
206 953 50       2299 $is_overridable{$dst_key} = 0 unless $this_overridable;
207             } ## end for my $src_key (keys $href...)
208             } ## end for my $href (@hrefs)
209 612         1549 return \%retval;
210             } ## end sub merge_hashes
211              
212             # collect options values from $args (= [...]) & other sources
213             # sets own configuration and residual_args
214             # acts based on what is provided by method options()
215 148     148   215 sub collect ($self, @args) {
  148         239  
  148         270  
  148         195  
216 148         241 my @sequence; # stuff collected from Sources, w/ context
217             my @slices; # ditto, no context
218 148         253 my $config = {}; # merged configuration
219 148         205 my @residual_args; # what is left from the @args at the end
220              
221 148         262 my $last_priority = 0;
222 148         397 for my $source ($self->sources) {
223 612 100       1605 my ($src, @opts) = ref($source) eq 'ARRAY' ? $source->@* : $source;
224 612 100 100     1644 my $meta = (@opts && ref $opts[0]) ? shift @opts : {};
225 612         1020 my $locator = $src;
226 612 100       1177 if (! ref($src)) {
227 610         1819 ($src, my $priority) = split m{=}mxs, $src;
228 610 100       1545 $meta->{priority} = $priority if defined $priority;
229 610         2354 $locator = $src =~ s{\A \+}{source_}rmxs;
230             }
231 612 50       1559 my $sub = $self->ref_to_sub($locator)
232             or die "unhandled source for $locator\n";
233 612         1674 my ($slice, $residuals) = $sub->($self, \@opts, \@args);
234 612 100       13763 push @residual_args, $residuals->@* if defined $residuals;
235 612   66     2041 $last_priority = my $priority = $meta->{priority} //= $last_priority + 10;
236 612         1626 push @sequence, [$priority, $src, \@opts, $locator, $slice];
237 612         1585 for (my $i = $#sequence; $i > 0; --$i) {
238 504 100       1704 last if $sequence[$i - 1][0] <= $sequence[$i][0];
239 41         134 @sequence[$i - 1, $i] = @sequence[$i, $i - 1];
240             }
241 612         1110 $config = $self->merge_hashes(map {$_->[-1]} @sequence);
  1585         2997  
242 612         1983 $self->_rwn(config => {merged => $config, sequence => \@sequence});
243             } ## end for my $source ($self->...)
244              
245             # save and return
246 148         555 $self->residual_args(\@residual_args);
247 148         344 return $self;
248             } ## end sub collect
249              
250 148     148   237 sub getopt_config ($self, @n) {
  148         193  
  148         214  
  148         198  
251 148         283 my $value = $self->_rw(@n);
252 148 50       430 if (!defined $value) {
253 148         378 my @r = qw< gnu_getopt >;
254 148 100       424 push @r, qw< require_order pass_through > if $self->list_children;
255 148 50       462 push @r, qw< pass_through > if $self->allow_residual_options;
256 148         387 $value = $self->_rw(\@r);
257             } ## end if (!defined $value)
258 148         757 return $value->@*;
259             } ## end sub getopt_config
260              
261 148     148   229 sub source_CmdLine ($self, $ignore, $args) {
  148         216  
  148         188  
  148         226  
  148         194  
262 148         503 my @args = $args->@*;
263              
264 148         10350 require Getopt::Long;
265 148         131123 Getopt::Long::Configure('default', $self->getopt_config);
266              
267 148         10209 my %option_for;
268             my @specs = map {
269 300         466 my $go = $_->{getopt};
270             ref($go) eq 'ARRAY'
271 0     0   0 ? ($go->[0] => sub { $go->[1]->(\%option_for, @_) })
272 300 50       707 : $go;
273             }
274 148         468 grep { exists $_->{getopt} } $self->options;
  300         715  
275 148 50       552 Getopt::Long::GetOptionsFromArray(\@args, \%option_for, @specs)
276             or die "bailing out\n";
277              
278             # Check if we want to forbid the residual @args to start with a '-'
279 148         39178 my $strict = !$self->allow_residual_options;
280 148 50 66     871 if ($strict && @args && $args[0] =~ m{\A -}mxs) {
      66        
281 0         0 Getopt::Long::Configure('default', 'gnu_getopt');
282 0         0 Getopt::Long::GetOptionsFromArray(\@args, {});
283 0         0 die "bailing out\n";
284             }
285              
286 148         547 return (\%option_for, \@args);
287             } ## end sub source_CmdLine
288              
289 293     293   381 sub name_for_option ($self, $o) {
  293         368  
  293         373  
  293         378  
290 293 50       661 return $o->{name} if defined $o->{name};
291 293 50 33     2532 return $1 if defined $o->{getopt} && $o->{getopt} =~ m{\A(\w+)}mxs;
292             return lc $o->{environment}
293 0 0 0     0 if defined $o->{environment} && $o->{environment} ne '1';
294 0         0 return '~~~';
295             } ## end sub name_for_option
296              
297 148     148   230 sub source_Default ($self, @ignore) {
  148         228  
  148         228  
  148         193  
298             return {
299 128         288 map { $self->name_for_option($_) => $_->{default} }
300 270         542 grep { exists $_->{default} }
301 148         324 grep { !$_->{inherited} } $self->options
  300         636  
302             };
303             } ## end sub source_Default
304              
305 3     3   7 sub source_FromTrail ($self, $trail, @ignore) {
  3         3  
  3         6  
  3         6  
  3         6  
306 3         7 my $conf = $self->config_hash;
307 3         9 for my $key ($trail->@*) {
308 9 50       21 return {} unless defined $conf->{$key};
309 9         13 $conf = $conf->{$key};
310 9 50       24 die "invalid trail $trail->@* for configuration gathering"
311             unless ref($conf) eq 'HASH';
312             } ## end for my $key ($keys->@*)
313 3         8 return $conf;
314             }
315              
316 303     303   438 sub environment_variable_name ($self, $ospec) {
  303         414  
  303         394  
  303         360  
317             my $env =
318             exists $ospec->{environment} ? $ospec->{environment}
319 303 100       761 : $self->auto_environment ? 1
    100          
320             : undef;
321 303 100 100     1112 return $env unless ($env // '') eq '1';
322              
323             # get prefixes all the way up to the first command
324 92         122 my @prefixes;
325 92         192 for (my $instance = $self; $instance; $instance = $instance->parent) {
326 100   50     183 unshift @prefixes, $instance->environment_prefix // '';
327             }
328              
329 92         214 return uc(join '', @prefixes, $self->name_for_option($ospec));
330             } ## end sub environment_variable_name
331              
332 148     148   200 sub source_Environment ($self, @ignore) {
  148         212  
  148         237  
  148         232  
333             return {
334             map {
335 270         571 my $en = $self->environment_variable_name($_);
336             defined($en)
337             && exists($ENV{$en})
338 270 100 100     1287 ? ($self->name_for_option($_) => $ENV{$en})
339             : ();
340 148         322 } grep { !$_->{inherited} } $self->options
  300         639  
341             };
342             } ## end sub source_Environment
343              
344 16     16   23 sub source_JsonFileFromConfig ($self, $key, @ignore) {
  16         35  
  16         22  
  16         24  
  16         25  
345 16   50     60 $key = $key->[0] // 'config';
346 16 100       42 defined(my $filename = $self->config($key)) or return {};
347 9         1652 require JSON::PP;
348 9         30395 return JSON::PP::decode_json($self->slurp($filename));
349             } ## end sub source_JsonFileFromConfig
350              
351 9     9   18 sub slurp ($self, $file, $mode = '<:encoding(UTF-8)') {
  9         18  
  9         17  
  9         15  
  9         18  
352 9 50       420 open my $fh, $mode, $file or die "open('$file'): $!\n";
353 9         24596 local $/;
354 9         389 return <$fh>;
355             }
356              
357 0     0   0 sub source_JsonFiles ($self, $candidates, @ignore) {
  0         0  
  0         0  
  0         0  
  0         0  
358 0         0 require JSON::PP;
359             return $self->merge_hashes(
360 0         0 map { JSON::PP::decode_json($self->slurp($_)) }
361 0         0 grep { -e $_ } $candidates->@*
  0         0  
362             );
363             } ## end sub source_JsonFiles
364              
365 146     146   217 sub source_Parent ($self, @ignore) {
  146         253  
  146         246  
  146         233  
366 146 100       318 my $parent = $self->parent or return {};
367 68         228 return $parent->config_hash(0);
368             }
369              
370              
371             # get the assembled config for the command. It supports the optional
372             # additional boolean parameter $blame to get back a more structured
373             # version where it's clear where each option comes from, to allow for
374             # further injection of parameters from elsewhere.
375 150     150   393 sub config_hash ($self, $blame = 0) {
  150         220  
  150         313  
  150         181  
376 150   50     274 my $config = $self->_rwn('config') // {};
377 150 50       326 return $config if $blame;
378 150   50     842 return $config->{merged} // {};
379             }
380              
381             # get one or more specific configurtion values
382 32     32   117 sub config ($self, @keys) {
  32         44  
  32         51  
  32         42  
383 32         80 my $hash = $self->config_hash(0);
384 32 50       159 return $hash->{$keys[0]} if @keys == 1;
385 0         0 return $hash->@{@keys};
386             }
387              
388 0     0   0 sub set_config ($self, $key, @value) {
  0         0  
  0         0  
  0         0  
  0         0  
389 0         0 my $hash = $self->config_hash(0);
390 0         0 delete $hash->{$key};
391 0 0       0 $hash->{$key} = $value[0] if @value;
392 0         0 return $self;
393             } ## end sub set_config
394              
395             # commit collected options values, called after collect ends
396 148     148   206 sub commit ($self, @n) {
  148         234  
  148         195  
  148         186  
397 148         287 my $commit = $self->_rw(@n);
398 148 50       366 return $commit if @n;
399 148 50       362 return unless $commit;
400 0         0 return $self->ref_to_sub($commit)->($self);
401             } ## end sub commit
402              
403             # validate collected options values, called after commit ends.
404 148     148   201 sub validate ($self, @n) {
  148         210  
  148         208  
  148         183  
405              
406             # Support the "accessor" interface for using a validation sub
407 148         274 my $validator = $self->_rw(@n);
408 148 50       363 return $validator if @n;
409              
410             # If set, it MUST be a validation sub reference. Otherwise, try the
411             # params_validate/Params::Validate path.
412 148 50       504 if ($validator) {
    50          
413 0 0       0 die "validator can only be a CODE reference\n"
414             unless ref $validator eq 'CODE';
415 0         0 $validator->($self);
416             }
417             elsif (my $params_validate = $self->params_validate) {
418 0         0 require Params::Validate;
419 0 0 0     0 if (my $config_validator = $params_validate->{config} // undef) {
420 0         0 my @array = $self->config_hash;
421 0         0 Params::Validate::validate(\@array, $config_validator);
422             }
423 0 0 0     0 if (my $args_validator = $params_validate->{args} // undef) {
424 0         0 my @array = $self->residual_args;
425 0         0 Params::Validate::validate_pos(\@array, $args_validator->@*);
426             }
427             }
428             else {} # no validation needed
429              
430 148         268 return $self;
431             } ## end sub validate ($self)
432              
433 81     81   117 sub find_matching_child ($self, $command) {
  81         124  
  81         137  
  81         98  
434 81 50       212 return unless defined $command;
435 81         189 for my $candidate ($self->list_children) {
436 132         369 my ($child) = $self->inflate_children($candidate);
437 132 100       441 return $child if $child->supports($command);
438             }
439 4         28 return;
440             } ## end sub find_matching_child
441              
442 26     26   54 sub _inflate_default_child ($self) {
  26         48  
  26         35  
443 26 50       60 defined(my $default = $self->default_child)
444             or die "undefined default child\n";
445 26 100       176 return undef if $default eq '-self';
446 4 50       14 my $child = $self->find_matching_child($default)
447             or die "no child matching the default $default\n";
448 4         25 return $child;
449             } ## end sub inflate_default_child ($self)
450              
451             # look for a child to hand execution over. Returns an child instance or
452             # undef (which means that the $self is in charge of executing
453             # something). This implements the most sensible default, deviations will
454             # have to be coded explicitly.
455             # Return values:
456             # - (undef, '-leaf') if no child exists
457             # - ($instance, @args) if a child is found with $args[0]
458             # - ($instance, '-default') if the default child is returned
459             # - (undef, '-fallback') in case $self is the fallback
460             # - ($instance, '-fallback', @args) in case the fallback is returned
461 148     148   210 sub find_child ($self) {
  148         259  
  148         183  
462 148 100       294 my @candidates = $self->list_children or return (undef, '-leaf');
463 91         240 my @residuals = $self->residual_args;
464 91 100       287 if (@residuals) {
    50          
465 65 100       222 if (my $child = $self->find_matching_child($residuals[0])) {
466 61         283 return ($child, @residuals);
467             } # otherwise... see what the fallback is about
468             }
469             elsif (defined(my $default = $self->default_child)) {
470 26         152 return ($self->_inflate_default_child, '-default');
471             }
472              
473             # try the fallback...
474 4         33 my $fallback = $self->fallback;
475 4 50       18 if (defined $fallback) {
476 0 0       0 return (undef, '-fallback') if $fallback eq '-self';
477 0 0       0 return ($self->_inflate_default_child, '-default')
478             if $fallback eq '-default';
479 0 0       0 if (my $child = $self->find_matching_child($fallback)) {
480 0         0 return ($child, -fallback => @residuals);
481             }
482             } ## end if (defined $fallback)
483              
484             # no fallback at this point... it's an error, build a message and die!
485             # FIXME this can be improved
486 4         78 die "cannot find sub-command '$residuals[0]'\n";
487             } ## end sub find_child ($self)
488              
489             # get the list of children. This only gives back a list of "hints" that
490             # can be turned into instances via inflate_children. In this case, it's
491             # module names
492 402     402   600 sub list_children ($self) {
  402         578  
  402         474  
493 402         881 my @children = $self->children;
494 402         1876 require File::Spec;
495             my @expanded_inc = map {
496 402         862 my ($v, $dirs) = File::Spec->splitpath($_, 'no-file');
  3707         14311  
497 3707         18880 [$v, File::Spec->splitdir($dirs)];
498             } @INC;
499 402         725 my %seen;
500             push @children, map {
501 402         1048 my @parts = split m{::}mxs, $_ . 'x';
  402         1498  
502 402         1058 substr(my $bprefix = pop @parts, -1, 1, '');
503             map {
504 402         665 my ($v, @dirs) = $_->@*;
  3707         12327  
505 3707         25962 my $dirs = File::Spec->catdir(@dirs, @parts);
506 3707 50       65201 if (opendir my $dh, File::Spec->catpath($v, $dirs, '')) {
507 0         0 grep { !$seen{$_}++ }
508             map {
509 0         0 substr(my $lastpart = $_, -3, 3, '');
510 0         0 join '::', @parts, $lastpart;
511             } grep {
512 0         0 my $path = File::Spec->catpath($v, $dirs, $_);
513 0 0 0     0 (-e $path && !-d $path)
      0        
514             && substr($_, 0, length($bprefix)) eq $bprefix
515             && substr($_, -3, 3) eq '.pm'
516 0         0 } sort { $a cmp $b } readdir $dh;
  0         0  
517             } ## end if (opendir my $dh, File::Spec...)
518 3707         18582 else { () }
519             } @expanded_inc;
520             } $self->children_prefixes;
521             push @children, map {
522 402         1244 my $prefix = $_;
  402         655  
523 44         196 grep { !$seen{$_}++ }
524             grep {
525 402         996 my $this_prefix = substr $_, 0, length $prefix;
  423         734  
526 423         941 $this_prefix eq $prefix;
527             } keys %App::Easer::V2::registered;
528             } $self->children_prefixes;
529 402 100 100     1115 push @children, $self->auto_children
530             if $self->force_auto_children // @children;
531 402         3605 return @children;
532             } ## end sub list_children ($self)
533              
534 844     844   1014 sub _auto_child ($self, $name, $inflate = 0) {
  844         1177  
  844         1051  
  844         1031  
  844         986  
535 844         2083 my $child = __PACKAGE__ . '::' . ucfirst(lc($name));
536 844 100       1508 ($child) = $self->inflate_children($child) if $inflate;
537 844         1879 return $child;
538             }
539              
540             # returns either class names or inflated objects
541 280     280   408 sub auto_children ($self, $inflate = 0) {
  280         392  
  280         414  
  280         363  
542 280         523 map { $self->_auto_child($_, $inflate) } qw< help commands tree >;
  840         1480  
543             }
544              
545 1     1   12 sub auto_commands ($self) { return $self->_auto_child('commands', 1) }
  1         2  
  1         2  
  1         4  
546              
547 3     3   12 sub auto_help ($self) { return $self->_auto_child('help', 1) }
  3         6  
  3         4  
  3         10  
548              
549 0     0   0 sub auto_tree ($self) { return $self->_auto_child('tree', 1) }
  0         0  
  0         0  
  0         0  
550              
551 1     1   9 sub run_help ($self) { return $self->auto_help->run($self->name) }
  1         2  
  1         3  
  1         4  
552 1     1   45 sub full_help_text ($s) { return $s->auto_help->collect_help_for($s) }
  1         3  
  1         2  
  1         5  
553              
554 0     0   0 sub load_module ($sop, $module) {
  0         0  
  0         0  
  0         0  
555 0         0 my $file = "$module.pm" =~ s{::}{/}grmxs;
556 0 0       0 eval { require $file } or Carp::confess("module<$module>: $EVAL_ERROR");
  0         0  
557 0         0 return $module;
558             }
559              
560             # Gets a specification like "Foo::Bar::baz" and returns a reference to
561             # sub "baz" in "Foo::Bar". If no package name is set, returns a
562             # reference to a sub in the package of $self. FIXME document properly
563 655     655   898 sub ref_to_sub ($self, $spec) {
  655         890  
  655         932  
  655         829  
564 655 50       1211 Carp::confess("undefined specification in ref_to_sub")
565             unless defined $spec;
566 655 100       1326 return $spec if ref($spec) eq 'CODE';
567 610 50       3360 my ($class, $function) =
568             ref($spec) eq 'ARRAY'
569             ? $spec->@*
570             : $spec =~ m{\A (?: (.*) :: )? (.*) \z}mxs;
571 610 100 100     4378 return $self->can($function) unless length($class // '');
572 1 50       12 $self->load_module($class) unless $class->can($function);
573 1         5 return $class->can($function);
574             } ## end sub ref_to_sub
575              
576 197     197   310 sub instantiate ($sop, $class, @args) {
  197         266  
  197         266  
  197         249  
  197         265  
577 197 50       1727 $sop->load_module($class) unless $class->can('new');
578 197         506 return $class->new(@args);
579             }
580              
581             # transform one or more children "hints" into instances.
582 161     161   224 sub inflate_children ($self, @hints) {
  161         232  
  161         239  
  161         205  
583 161         326 my $hashy = $self->hashy_class;
584             map {
585 197         296 my $child = $_;
586 197 50       492 if (!blessed($child)) { # actually inflate it
587 197 100       706 $child =
    100          
588             ref($child) eq 'ARRAY' ? $self->instantiate($child->@*)
589             : ref($child) eq 'HASH' ? $self->instantiate($hashy, $child)
590             : $self->instantiate($child);
591             } ## end if (!blessed($child))
592 197         648 $child->parent($self);
593 197         826 $child;
594 161         381 } grep { defined $_ } @hints;
  197         447  
595             } ## end sub inflate_children
596              
597             # fallback mechanism when finding a child, relies on fallback_to.
598 4     4   8 sub fallback ($self) {
  4         10  
  4         5  
599 4         14 my $fto = $self->fallback_to;
600 4 50 33     41 return $fto if !defined($fto) || $fto !~ m{\A(?: 0 | [1-9]\d* )\z};
601 0         0 my @children = $self->list_children;
602 0 0       0 return $children[$fto] if $fto <= $#children;
603 0         0 return undef;
604             } ## end sub fallback ($self)
605              
606             # execute what's set as the execute sub in the slot
607 43     43   65 sub execute ($self) {
  43         66  
  43         55  
608 43 50       82 my $spec = $self->_rw or die "nothing to search for execution\n";
609 43 50       139 my $sub = $self->ref_to_sub($spec) or die "nothing to execute\n";
610 43         148 return $sub->($self);
611             }
612              
613 148     148   218 sub run ($self, $name, @args) {
  148         240  
  148         238  
  148         241  
  148         187  
614 148         546 $self->call_name($name);
615 148         696 $self->collect(@args);
616 148         464 $self->commit;
617 148         467 $self->validate;
618 148         435 my ($child, @child_args) = $self->find_child;
619 144 100       575 return $child->run(@child_args) if defined $child;
620 79         386 $self->execution_reason($child_args[0]);
621 79         385 return $self->execute;
622             } ## end sub run
623              
624             package App::Easer::V2::Command::Commands;
625             push our @ISA, 'App::Easer::V2::Command';
626 27     27   61 sub aliases { 'commands' }
627 14     14   43 sub allow_residual_options { 0 }
628 0     0   0 sub description { 'Print list of supported sub-commands' }
629 17     17   47 sub help { 'list sub-commands' }
630 0     0   0 sub name { 'commands' }
631              
632 48     48   107 sub target ($self) {
  48         69  
  48         62  
633 48         118 my ($subc, @rest) = $self->residual_args;
634 48 50       131 die "this command does not support many arguments\n" if @rest;
635 48         158 my $target = $self->parent;
636 48 100       165 $target = $target->find_matching_child($subc) if defined $subc;
637 48 50       146 die "cannot find sub-command '$subc'\n" unless defined $target;
638 48         234 return $target;
639             } ## end sub target ($self)
640              
641 25     25   55 sub list_commands_for ($self, $target = undef) {
  25         49  
  25         45  
  25         35  
642 25   33     72 $target //= $self->target;
643 25         52 my @lines;
644 25         76 for my $command ($target->inflate_children($target->list_children)) {
645 61   50     258 my $help = $command->help // '(**missing help**)';
646 61         173 my @aliases = $command->aliases;
647 61 50       134 next unless @aliases;
648 61         234 push @lines, sprintf '%15s: %s', shift(@aliases), $help;
649 61 100       186 push @lines, sprintf '%15s (also as: %s)', '', join ', ', @aliases
650             if @aliases;
651             } ## end for my $command ($target...)
652 25 100       382 return unless @lines;
653 17         128 return join "\n", @lines;
654             } ## end sub list_commands_for
655              
656 24     24   44 sub help_channel ($self) { $self->target->help_channel }
  24         42  
  24         39  
  24         59  
657              
658 24     24   46 sub _build_printout_facility ($self) {
  24         53  
  24         35  
659 24         114 my $channel = $self->help_channel;
660 24         109 my $refch = ref $channel;
661              
662 24 50       94 return $channel if $refch eq 'CODE';
663              
664 24         38 my $fh;
665 24 50       121 if ($refch eq 'GLOB') {
    50          
    50          
666 0         0 $fh = $channel;
667             }
668             elsif ($refch eq 'SCALAR') {
669 0 0       0 open $fh, '>', $channel or die "open(): $!\n";
670             }
671             elsif ($refch) {
672 0         0 die 'invalid channel';
673             }
674             else {
675 24         119 ($channel, my $binmode) = split m{:}mxs, $channel, 2;
676 24 50 33     133 if ($channel eq '-' || lc($channel) eq '-stdout') {
    0          
677 24         61 $fh = \*STDOUT;
678             }
679             elsif (lc($channel) eq '-stderr') {
680 0         0 $fh = \*STDERR;
681             }
682             else {
683 0 0       0 open $fh, '>', $channel or die "open('$channel'): $!\n";
684             }
685 24 50 50 11   776 binmode $fh, $binmode if length($binmode // '');
  11         78  
  11         29  
  11         95  
686             }
687              
688 24     24   41 return sub ($cmd, @stuff) {
  24         41  
  24         45  
  24         56  
689 24         46 print {$fh} @stuff;
  24         1482  
690 24         180 return $cmd;
691             }
692 24         113203 }
693              
694 24     24   46 sub printout ($self, @stuff) {
  24         37  
  24         50  
  24         50  
695 24         57 my $pof = $self->_rw;
696 24 50       168 $self->_rw($pof = $self->_build_printout_facility) unless $pof;
697 24         111 $pof->($self, @stuff);
698             }
699              
700 7     7   26 sub execute ($self) {
  7         17  
  7         14  
701 7         24 my $target = $self->target;
702 7   33     36 my $name = $target->call_name // $target->name;
703 7 100       52 if (defined(my $commands = $self->list_commands_for($target))) {
704 6         50 $self->printout("sub-commands for $name\n", $commands, "\n");
705             }
706             else {
707 1         10 $self->printout("no sub-commands for $name\n");
708             }
709             } ## end sub execute ($self)
710              
711             package App::Easer::V2::Command::Help;
712             push our @ISA, 'App::Easer::V2::Command::Commands';
713 42     42   189 sub aliases { 'help' }
714 34     34   108 sub allow_residual_options { 0 }
715 0     0   0 sub description { 'Print help for (sub)command' }
716 17     17   62 sub help { 'print a help command' }
717 0     0   0 sub name { 'help' }
718              
719 33     33   59 sub __commandline_help ($getopt) {
  33         55  
  33         48  
720 33         43 my @retval;
721              
722 33         67 my ($mode, $type, $desttype, $min, $max, $default);
723 33 100       314 if (substr($getopt, -1, 1) eq '!') {
    100          
    100          
    100          
    100          
724 14         47 $type = 'bool-negatable';
725 14         38 substr $getopt, -1, 1, '';
726 14         47 push @retval, 'boolean (can be negated)';
727             }
728             elsif ($getopt =~ s<:\+ ([@%])? \z><>mxs) {
729 1         2 $mode = 'optional';
730 1         3 $type = 'i';
731 1         2 $default = 'increment';
732 1         2 $desttype = $1;
733 1         2 my $line = "integer, value is optional, defaults to incrementing current value";
734 1 50 33     4 $line .= ", list valued" if defined($desttype) && $desttype eq '@';
735 1         2 push @retval, $line;
736             } ## end elsif ($getopt =~ s<:+ ([@%])? \z><>mxs)
737             elsif (substr($getopt, -1, 1) eq '+') {
738 1         3 $mode = 'increment';
739 1         2 substr $getopt, -1, 1, '';
740 1         2 push @retval,
741             'incremental integer (adds 1 every time it is provided)';
742             } ## end elsif (substr($getopt, -1...))
743             elsif (
744             $getopt =~ s<(
745             [:=]) # 1 mode
746             ([siof]) # 2 type
747             ([@%])? # 3 desttype
748             (?:
749             \{
750             (\d*)? # 4 min
751             ,?
752             (\d*)? # 5 max
753             \}
754             )? \z><>mxs
755             )
756             {
757 15 100       66 $mode = $1 eq '=' ? 'required' : 'optional';
758 15         36 $type = $2;
759 15         36 $desttype = $3;
760 15         43 $min = $4;
761 15         30 $max = $5;
762 15 50       62 if (defined $min) {
763 0 0       0 $mode = $min ? 'optional' : 'required';
764             }
765             $type = {
766             s => 'string',
767             i => 'integer',
768             o => 'perl-extended-integer',
769             f => 'float',
770 15         98 }->{$type};
771 15         67 my $line = "$type, value is $mode";
772 15 50 33     61 $line .= ", at least $min times" if defined($min) && $min > 1;
773 15 50 33     62 $line .= ", no more than $max times"
774             if defined($max) && length($max);
775 15 100 66     59 $line .= ", list valued" if defined($desttype) && $desttype eq '@';
776 15         38 push @retval, $line;
777             } ## end elsif ($getopt =~ s<( ) )
778             elsif ($getopt =~ s<: (\d+) ([@%])? \z><>mxs) {
779 1         3 $mode = 'optional';
780 1         2 $type = 'i';
781 1         3 $default = $1;
782 1         2 $desttype = $2;
783 1         3 my $line = "integer, value is optional, defaults to $default";
784 1 50 33     14 $line .= ", list valued" if defined($desttype) && $desttype eq '@';
785 1         4 push @retval, $line;
786             } ## end elsif ($getopt =~ s<: (\d+) ([@%])? \z><>mxs)
787             else { # boolean, non-negatable
788 1         2 $type = 'bool';
789 1         3 push @retval, 'boolean';
790             }
791              
792 33         145 my @alternatives = split /\|/, $getopt;
793 33 100 100     296 if ($type eq 'bool-negatable') {
    100          
    100          
794             push @retval, map {
795 14 100       44 if (length($_) == 1) { "-$_" }
  26         68  
  12         43  
796 14         63 else { "--$_ | --no-$_" }
797             } @alternatives;
798             } ## end if ($type eq 'bool')
799             elsif ($type eq 'bool' || $mode eq 'increment') {
800             push @retval, map {
801 2 100       7 if (length($_) == 1) { "-$_" }
  3         8  
  1         4  
802 2         18 else { "--$_" }
803             } @alternatives;
804             } ## end if ($type eq 'bool')
805             elsif ($mode eq 'optional') {
806             push @retval, map {
807 3 50       5 if (length($_) == 1) { "-$_ []" }
  3         9  
  0         0  
808 3         24 else { "--$_ []" }
809             } @alternatives;
810             } ## end elsif ($mode eq 'optional')
811             else {
812             push @retval, map {
813 14 100       38 if (length($_) == 1) { "-$_ " }
  27         63  
  13         41  
814 14         58 else { "--$_ " }
815             } @alternatives;
816             } ## end else [ if ($type eq 'bool') ]
817              
818 33         132 return @retval;
819             } ## end sub __commandline_help ($getopt)
820              
821 17     17   91 sub execute ($self) {
  17         62  
  17         35  
822 17         115 $self->printout($self->collect_help_for($self->target));
823 17         562 return 0;
824             }
825              
826 18     18   41 sub collect_help_for ($self, $target = undef) {
  18         82  
  18         43  
  18         33  
827 18   33     81 $target //= $self->target;
828 18         33 my @stuff;
829              
830 18         67 push @stuff, $target->help, "\n\n";
831              
832 18 50       104 if (defined(my $description = $target->description)) {
833 18         199 $description =~ s{\A\s+|\s+\z}{}gmxs; # trim
834 18         103 $description =~ s{^}{ }gmxs; # add some indentation
835 18         72 push @stuff, "Description:\n$description\n\n";
836             }
837              
838             # Print this only for sub-commands, not for the root
839 18 100       60 push @stuff, sprintf "Can be called as: %s\n\n", join ', ',
840             $target->aliases
841             if $target->parent;
842              
843 18 100       84 if (my @options = $target->options) {
844 16         50 push @stuff, "Options:\n";
845 16         48 my $n = 0; # count the option
846 16         49 for my $opt (@options) {
847 33 100       141 push @stuff, "\n" if $n++; # from second line on
848              
849             push @stuff, sprintf "%15s: %s\n", $target->name_for_option($opt),
850 33   100     108 $opt->{help} // '';
851              
852 33 50       120 if (exists $opt->{getopt}) {
853 33         96 my @lines = __commandline_help($opt->{getopt});
854 33         160 push @stuff, sprintf "%15s command-line: %s\n", '',
855             shift(@lines);
856             push @stuff,
857 33         70 map { sprintf "%15s %s\n", '', $_ } @lines;
  59         206  
858             } ## end if (exists $opt->{getopt...})
859              
860 33 100       136 if (defined(my $env = $self->environment_variable_name($opt))) {
861 13         86 push @stuff, sprintf "%15s environment: %s\n", '', $env;
862             }
863              
864             push @stuff, sprintf "%15s default: %s\n", '',
865             $opt->{default} // '*undef*'
866 33 100 50     170 if exists $opt->{default};
867             } ## end for my $opt (@options)
868              
869 16         47 push @stuff, "\n";
870             } ## end if (my @options = $target...)
871             else {
872 2         14 push @stuff, "This command has no option\n";
873             }
874              
875 18 100       107 if (defined(my $commands = $self->list_commands_for($target))) {
876 11         47 push @stuff, "Sub-commands:\n", $commands, "\n";
877             }
878             else {
879 7         20 push @stuff, "No sub-commands\n";
880             }
881              
882 18         267 return join '', @stuff;
883             } ## end sub execute ($self)
884              
885             package App::Easer::V2::Command::Tree;
886             push our @ISA, 'App::Easer::V2::Command::Commands';
887 21     21   65 sub aliases { 'tree' }
888 0     0   0 sub description { 'Print tree of supported sub-commands' }
889 17     17   39 sub help { 'print sub-commands in a tree' }
890 0     0   0 sub name { 'tree' }
891              
892             sub options {
893             return (
894             {
895 0     0   0 getopt => 'include_auto|include-auto|I!',
896             default => 0,
897             environment => 1,
898             },
899             );
900             } ## end sub options
901              
902 0     0   0 sub list_commands_for ($self, $target) {
  0         0  
  0         0  
  0         0  
903 0 0       0 my $exclude_auto = $self->config('include_auto') ? 0 : 1;
904 0         0 my @lines;
905 0         0 for my $command ($target->inflate_children($target->list_children)) {
906 0 0       0 my ($name) = $command->aliases or next;
907             next
908 0 0 0     0 if $name =~ m{\A(?: help | commands | tree)\z}mxs && $exclude_auto;
909 0   0     0 my $help = $command->help // '(**missing help**)';
910 0         0 push @lines, sprintf '- %s (%s)', $name, $help;
911 0 0       0 if (defined(my $subtree = $self->list_commands_for($command))) {
912 0         0 push @lines, $subtree =~ s{^}{ }rgmxs;
913             }
914             } ## end for my $command ($target...)
915 0 0       0 return unless @lines;
916 0         0 return join "\n", @lines;
917             } ## end sub list_commands_for
918              
919             1;