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