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