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