Move _gld_spec to ::GLD - it's only used there.
[gitmo/MooseX-Getopt.git] / lib / MooseX / Getopt / Basic.pm
CommitLineData
ef47fe44 1package MooseX::Getopt::Basic;
2use Moose::Role;
3
30ed85f7 4use MooseX::Getopt::OptionTypeMap;
5use MooseX::Getopt::Meta::Attribute;
6use MooseX::Getopt::Meta::Attribute::NoGetopt;
7use Carp ();
8
9use Getopt::Long (); # GLD uses it anyway, doesn't hurt
10
11our $VERSION = '0.20';
12our $AUTHORITY = 'cpan:STEVAN';
13
14has ARGV => (is => 'rw', isa => 'ArrayRef', metaclass => "NoGetopt");
15has extra_argv => (is => 'rw', isa => 'ArrayRef', metaclass => "NoGetopt");
16
17# _getopt_spec() and _getoptions() are overrided by MooseX::Getopt::GLD.
18
ef47fe44 19sub _getopt_spec {
20 my ($class, %params) = @_;
21 return $class->_traditional_spec(%params)
22}
23
24sub _get_options {
25 my ($class, undef, $opt_spec) = @_;
26 my %options;
27 Getopt::Long::GetOptions(\%options, @$opt_spec);
28 return ( \%options, undef );
29}
30
30ed85f7 31sub new_with_options {
32 my ($class, @params) = @_;
33
34 my $config_from_file;
35 if($class->meta->does_role('MooseX::ConfigFromFile')) {
36 local @ARGV = @ARGV;
37
38 my $configfile;
39 my $opt_parser = Getopt::Long::Parser->new( config => [ qw( pass_through ) ] );
40 $opt_parser->getoptions( "configfile=s" => \$configfile );
41
42 if(!defined $configfile) {
43 my $cfmeta = $class->meta->find_attribute_by_name('configfile');
44 $configfile = $cfmeta->default if $cfmeta->has_default;
45 }
46
47 if(defined $configfile) {
48 $config_from_file = $class->get_config_from_file($configfile);
49 }
50 }
51
52 my $constructor_params = ( @params == 1 ? $params[0] : {@params} );
53
54 Carp::croak("Single parameters to new_with_options() must be a HASH ref")
55 unless ref($constructor_params) eq 'HASH';
56
57 my %processed = $class->_parse_argv(
58 options => [
59 $class->_attrs_to_options( $config_from_file )
60 ],
61 params => $constructor_params,
62 );
63
64 my $params = $config_from_file ? { %$config_from_file, %{$processed{params}} } : $processed{params};
65
66 # did the user request usage information?
67 if ( $processed{usage} && ($params->{'?'} or $params->{help} or $params->{usage}) )
68 {
69 $processed{usage}->die();
70 }
71
72 $class->new(
73 ARGV => $processed{argv_copy},
74 extra_argv => $processed{argv},
75 %$constructor_params, # explicit params to ->new
76 %$params, # params from CLI
77 );
78}
79
80sub _parse_argv {
81 my ( $class, %params ) = @_;
82
83 local @ARGV = @{ $params{params}{argv} || \@ARGV };
84
85 my ( $opt_spec, $name_to_init_arg ) = $class->_getopt_spec(%params);
86
87 # Get a clean copy of the original @ARGV
88 my $argv_copy = [ @ARGV ];
89
90 my @err;
91
92 my ( $parsed_options, $usage ) = eval {
93 local $SIG{__WARN__} = sub { push @err, @_ };
94
95 return $class->_get_options(\%params, $opt_spec);
96 };
97
98 die join "", grep { defined } @err, $@ if @err or $@;
99
100 # Get a copy of the Getopt::Long-mangled @ARGV
101 my $argv_mangled = [ @ARGV ];
102
103 my %constructor_args = (
104 map {
105 $name_to_init_arg->{$_} => $parsed_options->{$_}
106 } keys %$parsed_options,
107 );
108
109 return (
110 params => \%constructor_args,
111 argv_copy => $argv_copy,
112 argv => $argv_mangled,
113 ( defined($usage) ? ( usage => $usage ) : () ),
114 );
115}
116
117sub _usage_format {
118 return "usage: %c %o";
119}
120
121sub _traditional_spec {
122 my ( $class, %params ) = @_;
123
124 my ( @options, %name_to_init_arg, %options );
125
126 foreach my $opt ( @{ $params{options} } ) {
127 push @options, $opt->{opt_string};
128
129 my $identifier = $opt->{name};
130 $identifier =~ s/\W/_/g; # Getopt::Long does this to all option names
131
132 $name_to_init_arg{$identifier} = $opt->{init_arg};
133 }
134
135 return ( \@options, \%name_to_init_arg );
136}
137
30ed85f7 138sub _compute_getopt_attrs {
139 my $class = shift;
140 grep {
141 $_->does("MooseX::Getopt::Meta::Attribute::Trait")
142 or
143 $_->name !~ /^_/
144 } grep {
145 !$_->does('MooseX::Getopt::Meta::Attribute::Trait::NoGetopt')
146 } $class->meta->get_all_attributes
147}
148
149sub _get_cmd_flags_for_attr {
150 my ( $class, $attr ) = @_;
151
152 my $flag = $attr->name;
153
154 my @aliases;
155
156 if ($attr->does('MooseX::Getopt::Meta::Attribute::Trait')) {
157 $flag = $attr->cmd_flag if $attr->has_cmd_flag;
158 @aliases = @{ $attr->cmd_aliases } if $attr->has_cmd_aliases;
159 }
160
161 return ( $flag, @aliases );
162}
163
164sub _attrs_to_options {
165 my $class = shift;
166 my $config_from_file = shift || {};
167
168 my @options;
169
170 foreach my $attr ($class->_compute_getopt_attrs) {
171 my ( $flag, @aliases ) = $class->_get_cmd_flags_for_attr($attr);
172
173 my $opt_string = join(q{|}, $flag, @aliases);
174
175 if ($attr->name eq 'configfile') {
176 $opt_string .= '=s';
177 }
178 elsif ($attr->has_type_constraint) {
179 my $type = $attr->type_constraint;
180 if (MooseX::Getopt::OptionTypeMap->has_option_type($type)) {
181 $opt_string .= MooseX::Getopt::OptionTypeMap->get_option_type($type)
182 }
183 }
184
185 push @options, {
186 name => $flag,
187 init_arg => $attr->init_arg,
188 opt_string => $opt_string,
189 required => $attr->is_required && !$attr->has_default && !$attr->has_builder && !exists $config_from_file->{$attr->name},
190 # NOTE:
191 # this "feature" was breaking because
192 # Getopt::Long::Descriptive would return
193 # the default value as if it was a command
194 # line flag, which would then override the
195 # one passed into a constructor.
196 # See 100_gld_default_bug.t for an example
197 # - SL
198 #( ( $attr->has_default && ( $attr->is_default_a_coderef xor $attr->is_lazy ) ) ? ( default => $attr->default({}) ) : () ),
199 ( $attr->has_documentation ? ( doc => $attr->documentation ) : () ),
200 }
201 }
202
203 return @options;
204}
205
206no Moose::Role; 1;
207
ef47fe44 2081;
209
210=pod
211
212=head1 NAME
213
214MooseX::Getopt::Basic - role to implement the basic functionality of
215L<MooseX::Getopt> without GLD.
216
217=head1 SYNOPSIS
218
219 ## In your class
220 package My::App;
221 use Moose;
222
223 with 'MooseX::Getopt';
224
225 has 'out' => (is => 'rw', isa => 'Str', required => 1);
226 has 'in' => (is => 'rw', isa => 'Str', required => 1);
227
228 # ... rest of the class here
229
230 ## in your script
231 #!/usr/bin/perl
232
233 use My::App;
234
235 my $app = My::App->new_with_options();
236 # ... rest of the script here
237
238 ## on the command line
239 % perl my_app_script.pl -in file.input -out file.dump
240
241=head1 DESCRIPTION
242
243This is a role which provides an alternate constructor for creating
244objects using parameters passed in from the command line.
245
246This module attempts to DWIM as much as possible with the command line
247params by introspecting your class's attributes. It will use the name
248of your attribute as the command line option, and if there is a type
249constraint defined, it will configure Getopt::Long to handle the option
250accordingly.
251
252You can use the trait L<MooseX::Getopt::Meta::Attribute::Trait> or the
253attribute metaclass L<MooseX::Getopt::Meta::Attribute> to get non-default
254commandline option names and aliases.
255
256You can use the trait L<MooseX::Getopt::Meta::Attribute::Trait::NoGetopt>
257or the attribute metaclass L<MooseX::Getopt::Meta::Attribute::NoGetopt>
258to have C<MooseX::Getopt> ignore your attribute in the commandline options.
259
260By default, attributes which start with an underscore are not given
261commandline argument support, unless the attribute's metaclass is set
262to L<MooseX::Getopt::Meta::Attribute>. If you don't want you accessors
263to have the leading underscore in thier name, you can do this:
264
265 # for read/write attributes
266 has '_foo' => (accessor => 'foo', ...);
267
268 # or for read-only attributes
269 has '_bar' => (reader => 'bar', ...);
270
271This will mean that Getopt will not handle a --foo param, but your
272code can still call the C<foo> method.
273
274If your class also uses a configfile-loading role based on
275L<MooseX::ConfigFromFile>, such as L<MooseX::SimpleConfig>,
276L<MooseX::Getopt>'s C<new_with_options> will load the configfile
277specified by the C<--configfile> option (or the default you've
278given for the configfile attribute) for you.
279
280Options specified in multiple places follow the following
281precendence order: commandline overrides configfile, which
282overrides explicit new_with_options parameters.
283
284=head2 Supported Type Constraints
285
286=over 4
287
288=item I<Bool>
289
290A I<Bool> type constraint is set up as a boolean option with
291Getopt::Long. So that this attribute description:
292
293 has 'verbose' => (is => 'rw', isa => 'Bool');
294
295would translate into C<verbose!> as a Getopt::Long option descriptor,
296which would enable the following command line options:
297
298 % my_script.pl --verbose
299 % my_script.pl --noverbose
300
301=item I<Int>, I<Float>, I<Str>
302
303These type constraints are set up as properly typed options with
304Getopt::Long, using the C<=i>, C<=f> and C<=s> modifiers as appropriate.
305
306=item I<ArrayRef>
307
308An I<ArrayRef> type constraint is set up as a multiple value option
309in Getopt::Long. So that this attribute description:
310
311 has 'include' => (
312 is => 'rw',
313 isa => 'ArrayRef',
314 default => sub { [] }
315 );
316
317would translate into C<includes=s@> as a Getopt::Long option descriptor,
318which would enable the following command line options:
319
320 % my_script.pl --include /usr/lib --include /usr/local/lib
321
322=item I<HashRef>
323
324A I<HashRef> type constraint is set up as a hash value option
325in Getopt::Long. So that this attribute description:
326
327 has 'define' => (
328 is => 'rw',
329 isa => 'HashRef',
330 default => sub { {} }
331 );
332
333would translate into C<define=s%> as a Getopt::Long option descriptor,
334which would enable the following command line options:
335
336 % my_script.pl --define os=linux --define vendor=debian
337
338=back
339
340=head2 Custom Type Constraints
341
342It is possible to create custom type constraint to option spec
343mappings if you need them. The process is fairly simple (but a
344little verbose maybe). First you create a custom subtype, like
345so:
346
347 subtype 'ArrayOfInts'
348 => as 'ArrayRef'
349 => where { scalar (grep { looks_like_number($_) } @$_) };
350
351Then you register the mapping, like so:
352
353 MooseX::Getopt::OptionTypeMap->add_option_type_to_map(
354 'ArrayOfInts' => '=i@'
355 );
356
357Now any attribute declarations using this type constraint will
358get the custom option spec. So that, this:
359
360 has 'nums' => (
361 is => 'ro',
362 isa => 'ArrayOfInts',
363 default => sub { [0] }
364 );
365
366Will translate to the following on the command line:
367
368 % my_script.pl --nums 5 --nums 88 --nums 199
369
370This example is fairly trivial, but more complex validations are
371easily possible with a little creativity. The trick is balancing
372the type constraint validations with the Getopt::Long validations.
373
374Better examples are certainly welcome :)
375
376=head2 Inferred Type Constraints
377
378If you define a custom subtype which is a subtype of one of the
379standard L</Supported Type Constraints> above, and do not explicitly
380provide custom support as in L</Custom Type Constraints> above,
381MooseX::Getopt will treat it like the parent type for Getopt
382purposes.
383
384For example, if you had the same custom C<ArrayOfInts> subtype
385from the examples above, but did not add a new custom option
386type for it to the C<OptionTypeMap>, it would be treated just
387like a normal C<ArrayRef> type for Getopt purposes (that is,
388C<=s@>).
389
390=head1 METHODS
391
392=over 4
393
394=item B<new_with_options (%params)>
395
396This method will take a set of default C<%params> and then collect
397params from the command line (possibly overriding those in C<%params>)
398and then return a newly constructed object.
399
400The special parameter C<argv>, if specified should point to an array
401reference with an array to use instead of C<@ARGV>.
402
ef47fe44 403If L<Getopt::Long/GetOptions> fails (due to invalid arguments),
404C<new_with_options> will throw an exception.
405
406If L<Getopt::Long::Descriptive> is installed and any of the following
407command line params are passed, the program will exit with usage
408information. You can add descriptions for each option by including a
409B<documentation> option for each attribute to document.
410
411 --?
412 --help
413 --usage
414
415If you have L<Getopt::Long::Descriptive> a the C<usage> param is also passed to
416C<new>.
417
418=item B<ARGV>
419
420This accessor contains a reference to a copy of the C<@ARGV> array
421as it originally existed at the time of C<new_with_options>.
422
423=item B<extra_argv>
424
425This accessor contains an arrayref of leftover C<@ARGV> elements that
426L<Getopt::Long> did not parse. Note that the real C<@ARGV> is left
427un-mangled.
428
429=item B<meta>
430
431This returns the role meta object.
432
433=back
434
435=head1 BUGS
436
437All complex software has bugs lurking in it, and this module is no
438exception. If you find a bug please either email me, or add the bug
439to cpan-RT.
440
441=head1 AUTHOR
442
443Stevan Little E<lt>stevan@iinteractive.comE<gt>
444
445Brandon L. Black, E<lt>blblack@gmail.comE<gt>
446
447Yuval Kogman, E<lt>nothingmuch@woobling.orgE<gt>
448
449=head1 CONTRIBUTORS
450
451Ryan D Johnson, E<lt>ryan@innerfence.comE<gt>
452
453Drew Taylor, E<lt>drew@drewtaylor.comE<gt>
454
455=head1 COPYRIGHT AND LICENSE
456
457Copyright 2007-2008 by Infinity Interactive, Inc.
458
459L<http://www.iinteractive.com>
460
461This library is free software; you can redistribute it and/or modify
462it under the same terms as Perl itself.
463
464=cut
465