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