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