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