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