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