lib/MooseX/Getopt.pm

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