File Coverage

lib/Class/Usul/Options.pm
Criterion Covered Total %
statement 61 63 96.8
branch 6 6 100.0
condition n/a
subroutine 13 13 100.0
pod 1 1 100.0
total 81 83 97.5


line stmt bran cond sub pod time code
1             package Class::Usul::Options;
2              
3 19     19   139131 use strict;
  19         57  
  19         589  
4 19     19   102 use warnings;
  19         59  
  19         604  
5              
6 19     19   690 use Class::Usul::Constants qw( FALSE TRUE );
  19         59  
  19         185  
7 19     19   14480 use Class::Usul::Functions qw( throw );
  19         56  
  19         126  
8 19     19   23759 use Sub::Install qw( install_sub );
  19         56  
  19         205  
9              
10             my @option_attributes
11             = qw( autosplit config doc format json negateable order repeatable short );
12              
13             my @banished_keywords
14             = qw( extra_argv new_with_options next_argv option _options_data
15             _options_config options_usage unshift_argv untainted_argv );
16              
17             # Private functions
18             my $filter_attributes = sub {
19             my %attributes = @_; my %filter_key = map { $_ => 1 } @option_attributes;
20              
21             return map { ( $_ => $attributes{ $_ } ) }
22             grep { not exists $filter_key{ $_ } } keys %attributes;
23             };
24              
25             my $validate_and_filter_options = sub {
26             my (%options) = @_;
27              
28             defined $options{doc } or $options{doc } = $options{documentation};
29             defined $options{order} or $options{order} = 0;
30              
31             if ($options{json}) {
32             delete $options{repeatable}; delete $options{autosplit};
33             delete $options{negateable}; $options{format} = 's';
34             }
35              
36             my %cmdline_options = map { ( $_ => $options{ $_ } ) }
37             grep { exists $options{ $_ } } @option_attributes, 'required';
38              
39             $cmdline_options{autosplit } and $cmdline_options{repeatable} = TRUE;
40             $cmdline_options{repeatable}
41             and defined $cmdline_options{format}
42             and (substr $cmdline_options{format}, -1) ne '@'
43             and $cmdline_options{format} .= '@';
44              
45             $cmdline_options{negateable} and defined $cmdline_options{format} and
46             throw 'Negateable parameters are not usable with a non boolean values';
47              
48             return %cmdline_options;
49             };
50              
51             # Public functions
52             sub default_options_config () {
53 93     93 1 1113 return getopt_conf => [],
54             prefer_commandline => TRUE,
55             protect_argv => TRUE,
56             show_defaults => FALSE,
57             skip_options => [],
58             usage_conf => {},
59             usage_opt => 'Usage: %c %o [method]';
60             }
61              
62             sub import {
63 93     93   747 my ($class, @args) = @_; my $target = caller;
  93         361  
64              
65 93         378 my $options_config = { default_options_config, @args };
66              
67 93         418 for my $want (grep { not $target->can( $_ ) } qw( around has with )) {
  279         2272  
68 0         0 throw 'Method [_1] not found in class [_2]', [ $want, $target ];
69             }
70              
71 93         444 my $around = $target->can( 'around' );
72 93         395 my $has = $target->can( 'has' );
73 93         403 my $with = $target->can( 'with' );
74              
75 19     19   10384 my @target_isa; { no strict 'refs'; @target_isa = @{ "${target}::ISA" } };
  19         57  
  19         7642  
  93         224  
  93         190  
  93         231  
  93         697  
76              
77 93 100       508 if (@target_isa) {
78             # Don't add this to a role. The ISA of a role is always empty!
79             install_sub { as => '_options_config', into => $target, code => sub {
80 6     6   25 return shift->maybe::next::method( @_ );
81 21         179 }, };
82              
83             install_sub { as => '_options_data', into => $target, code => sub {
84 6     6   85 return shift->maybe::next::method( @_ );
85 21         1501 }, };
86              
87             $around->( '_options_config' => sub {
88 6     6   203 my ($orig, $self, @args) = @_;
89              
90 6         22 return $orig->( $self, @args ), %{ $options_config };
  6         88  
91 21         1219 } );
92             }
93              
94 93         8308 my $options_data = {};
95             my $apply_modifiers = sub {
96 372 100   372   3185 $target->can( 'new_with_options' ) and return;
97              
98 165         804 $with->( 'Class::Usul::TraitFor::UntaintedGetopts' );
99              
100             $around->( '_options_data' => sub {
101 22         398 my ($orig, $self, @args) = @_;
102              
103 22         277 return $orig->( $self, @args ), %{ $options_data };
  22         208  
104 165         186603 } );
105 93         648 };
106             my $option = sub {
107 279     279   3811 my ($name, %attributes) = @_;
108              
109 279         961 for my $ban (grep { $_ eq $name } @banished_keywords) {
  2511         6470  
110 0         0 throw 'Method [_1] used by class [_2] as an attribute',
111             [ $ban, $target ];
112             }
113              
114 279         1442 $has->( $name => $filter_attributes->( %attributes ) );
115              
116 279         285574 $options_data->{ $name }
117             = { $validate_and_filter_options->( %attributes ) };
118              
119 279         1219 $apply_modifiers->(); # TODO: I think this can go
120 279         2430 return;
121 93         553 };
122 93         246 my $info; $info = $Role::Tiny::INFO{ $target }
123 93 100       612 and $info->{not_methods}{ $option } = $option;
124              
125 93         1229 install_sub { as => 'option', into => $target, code => $option, };
126              
127 93         8097 $apply_modifiers->();
128 93         281876 return;
129             }
130              
131             1;
132              
133             __END__
134              
135             =pod
136              
137             =encoding utf-8
138              
139             =head1 Name
140              
141             Class::Usul::Options - Command line processing
142              
143             =head1 Synopsis
144              
145             use Class::Usul::Types qw( Str );
146             use Moo;
147             use Class::Usul::Options;
148              
149             option 'my_attr' => is => 'ro', isa => 'Str',
150             documentation => 'This appears in the option usage output',
151             format => 's', short => 'a';
152              
153             # OR
154             # Causes Getopt::Long:Descriptive::Usage to produce it's new default output
155              
156             use Class::Usul::Options 'usage_conf' => {
157             highlight => 'none', option_type => 'verbose', tabstop => 8 };
158              
159             # OR
160             # Causes Getopt::Long:Descriptive::Usage to produce it's old default output
161              
162             use Class::Usul::Options 'usage_conf' => {
163             highlight => 'none', option_type => 'none', tabstop => 8 };
164              
165             =head1 Description
166              
167             This is an extended clone of L<MooX::Options> but is closer to
168             L<MooseX::Getopt::Dashes>
169              
170             =head1 Configuration and Environment
171              
172             The C<option> function accepts the following attributes in addition to those
173             already supported by C<has>
174              
175             =over 3
176              
177             =item C<autosplit>
178              
179             If set split the option value using this string. Automatically creates a list
180             of values
181              
182             =item C<config>
183              
184             A hash reference passed as the third element in the
185             list of tuples which forms the second argument to the
186             L<describe options|Getopt::Long::Descriptive/describe_options> function
187              
188             For example;
189              
190             option 'my_attr' => is => 'ro', isa => 'Str', config => { hidden => 1 },
191             documentation => 'This appears in the option usage output',
192             format => 's', short => 'a';
193              
194             would prevent the option from appearing in the usage text
195              
196             =item C<doc>
197              
198             Alias for C<documentation>. Used to describe the attribute in the usage output
199              
200             =item C<format>
201              
202             Format of the parameters, same as L<Getopt::Long::Descriptive>
203              
204             i : integer
205              
206             i@: array of integer
207              
208             s : string
209              
210             s@: array of string
211              
212             s%: hash of string
213              
214             f : float value
215              
216             By default, it's a boolean value.
217              
218             =item C<json>
219              
220             Boolean which if true means that the argument to the option is in JSON format
221             and will be decoded as such
222              
223             =item C<negateable>
224              
225             Applies only to boolean types. Means you can use C<--nooption-name> to
226             explicitly indicate false
227              
228             =item C<order>
229              
230             Specifies the order in which usage options appear. Attributes with no C<order>
231             value are alpha sorted
232              
233             =item C<repeatable>
234              
235             Boolean which if true means that the option can appear multiple times on the
236             command line
237              
238             =item C<short>
239              
240             A single character that can be used as a short option, e.g. C<-s> instead
241             of the longer C<--long-option>
242              
243             =back
244              
245             Defines no attributes
246              
247             =head1 Subroutines/Methods
248              
249             =head2 C<default_options_config>
250              
251             Returns a list of keys and values. These are the defaults for the configuration
252             options listed in L</import>
253              
254             =head2 C<import>
255              
256             Injects the C<option> function into the caller
257              
258             Accepts the following configuration options;
259              
260             =over 3
261              
262             =item C<getopf_conf>
263              
264             An array reference of options passed to L<Getopt::Long::Configure>, defaults to
265             an empty list
266              
267             =item C<prefer_commandline>
268              
269             A boolean which defaults to true. Prefer the command line values
270              
271             =item C<protect_argv>
272              
273             A boolean which defaults to true. Localises the C<@ARGV> variable before any
274             processing takes place. Means that C<@ARGV> will contain all of the passed
275             command line arguments
276              
277             =item C<show_defaults>
278              
279             A boolean which defaults to false. If true the default values are added to
280             use options usage text output
281              
282             =item C<skip_options>
283              
284             An array reference which defaults to an empty list. List of options to
285             ignore when processing the attributes passed to the C<option> subroutine
286              
287             =item C<usage_conf>
288              
289             By default an empty hash reference. Attributes can be any of;
290              
291             =over 3
292              
293             =item C<highlight>
294              
295             Defaults to C<bold> which causes the option argument types to be displayed
296             in a bold font. Set to C<none> to turn off highlighting
297              
298             =item C<option_type>
299              
300             One of; C<none>, C<short>, or C<verbose>. Determines the amount of option
301             type information displayed by the L<option_text|Class::Usul::Usage/option_text>
302             method. Defaults to C<short>
303              
304             =item C<tabstop>
305              
306             Defaults to 3. The number of spaces to expand the leading tab in the usage
307             string
308              
309             =item C<width>
310              
311             The total line width available for displaying usage text, defaults to 78
312              
313             =back
314              
315             =item C<usage_opt>
316              
317             The usage option string passed as the first argument to the
318             L<describe options|Getopt::Long::Descriptive/describe_options> function.
319             Defaulted in L</default_options_config> to C<Usage: %c %o [method]>
320              
321             =back
322              
323             =head1 Diagnostics
324              
325             None
326              
327             =head1 Dependencies
328              
329             =over 3
330              
331             =item L<Sub::Install>
332              
333             =back
334              
335             =head1 Incompatibilities
336              
337             There are no known incompatibilities in this module
338              
339             =head1 Bugs and Limitations
340              
341             There are no known bugs in this module. Please report problems to
342             http://rt.cpan.org/NoAuth/Bugs.html?Dist=Class-Usul.
343             Patches are welcome
344              
345             =head1 Acknowledgements
346              
347             Larry Wall - For the Perl programming language
348              
349             =head1 Author
350              
351             Peter Flanigan, C<< <pjfl@cpan.org> >>
352              
353             =head1 License and Copyright
354              
355             Copyright (c) 2017 Peter Flanigan. All rights reserved
356              
357             This program is free software; you can redistribute it and/or modify it
358             under the same terms as Perl itself. See L<perlartistic>
359              
360             This program is distributed in the hope that it will be useful,
361             but WITHOUT WARRANTY; without even the implied warranty of
362             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE
363              
364             =cut
365              
366             # Local Variables:
367             # mode: perl
368             # tab-width: 3
369             # End: