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