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.16';
  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         @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->has_type_constraint) {
 197             my $type = $attr->type_constraint;
 198             if (MooseX::Getopt::OptionTypeMap->has_option_type($type)) {
 199                 $opt_string .= MooseX::Getopt::OptionTypeMap->get_option_type($type)
 200             }
 201         }
 202
 203         push @options, {
 204             name       => $flag,
 205             init_arg   => $attr->init_arg,
 206             opt_string => $opt_string,
 207             required   => $attr->is_required && !$attr->has_default && !$attr->has_builder && !exists $config_from_file->{$attr->name},
 208             # NOTE:
 209             # this "feature" was breaking because
 210             # Getopt::Long::Descriptive would return
 211             # the default value as if it was a command
 212             # line flag, which would then override the
 213             # one passed into a constructor.
 214             # See 100_gld_default_bug.t for an example
 215             # - SL
 216             #( ( $attr->has_default && ( $attr->is_default_a_coderef xor $attr->is_lazy ) ) ? ( default => $attr->default({}) ) : () ),
 217             ( $attr->has_documentation ? ( doc => $attr->documentation ) : () ),
 218         }
 219     }
 220
 221     return @options;
 222 }
 223
 224 no Moose::Role; 1;
 225
 226 __END__
 227
 228 =pod
 229
 230 =head1 NAME
 231
 232 MooseX::Getopt - A Moose role for processing command line options
 233
 234 =head1 SYNOPSIS
 235
 236   ## In your class
 237   package My::App;
 238   use Moose;
 239
 240   with 'MooseX::Getopt';
 241
 242   has 'out' => (is => 'rw', isa => 'Str', required => 1);
 243   has 'in'  => (is => 'rw', isa => 'Str', required => 1);
 244
 245   # ... rest of the class here
 246
 247   ## in your script
 248   #!/usr/bin/perl
 249
 250   use My::App;
 251
 252   my $app = My::App->new_with_options();
 253   # ... rest of the script here
 254
 255   ## on the command line
 256   % perl my_app_script.pl -in file.input -out file.dump
 257
 258 =head1 DESCRIPTION
 259
 260 This is a role which provides an alternate constructor for creating
 261 objects using parameters passed in from the command line.
 262
 263 This module attempts to DWIM as much as possible with the command line
 264 params by introspecting your class's attributes. It will use the name
 265 of your attribute as the command line option, and if there is a type
 266 constraint defined, it will configure Getopt::Long to handle the option
 267 accordingly.
 268
 269 You can use the trait L<MooseX::Getopt::Meta::Attribute::Trait> or the
 270 attribute metaclass L<MooseX::Getopt::Meta::Attribute> to get non-default
 271 commandline option names and aliases.
 272
 273 You can use the trait L<MooseX::Getopt::Meta::Attribute::Trait::NoGetopt>
 274 or the attribute metaclass L<MooseX::Getopt::Meta::Attribute::NoGetopt>
 275 to have C<MooseX::Getopt> ignore your attribute in the commandline options.
 276
 277 By default, attributes which start with an underscore are not given
 278 commandline argument support, unless the attribute's metaclass is set
 279 to L<MooseX::Getopt::Meta::Attribute>. If you don't want you accessors
 280 to have the leading underscore in thier name, you can do this:
 281
 282   # for read/write attributes
 283   has '_foo' => (accessor => 'foo', ...);
 284
 285   # or for read-only attributes
 286   has '_bar' => (reader => 'bar', ...);
 287
 288 This will mean that Getopt will not handle a --foo param, but your
 289 code can still call the C<foo> method.
 290
 291 If your class also uses a configfile-loading role based on
 292 L<MooseX::ConfigFromFile>, such as L<MooseX::SimpleConfig>,
 293 L<MooseX::Getopt>'s C<new_with_options> will load the configfile
 294 specified by the C<--configfile> option (or the default you've
 295 given for the configfile attribute) for you.
 296
 297 Options specified in multiple places follow the following
 298 precendence order: commandline overrides configfile, which
 299 overrides explicit new_with_options parameters.
 300
 301 =head2 Supported Type Constraints
 302
 303 =over 4
 304
 305 =item I<Bool>
 306
 307 A I<Bool> type constraint is set up as a boolean option with
 308 Getopt::Long. So that this attribute description:
 309
 310   has 'verbose' => (is => 'rw', isa => 'Bool');
 311
 312 would translate into C<verbose!> as a Getopt::Long option descriptor,
 313 which would enable the following command line options:
 314
 315   % my_script.pl --verbose
 316   % my_script.pl --noverbose
 317
 318 =item I<Int>, I<Float>, I<Str>
 319
 320 These type constraints are set up as properly typed options with
 321 Getopt::Long, using the C<=i>, C<=f> and C<=s> modifiers as appropriate.
 322
 323 =item I<ArrayRef>
 324
 325 An I<ArrayRef> type constraint is set up as a multiple value option
 326 in Getopt::Long. So that this attribute description:
 327
 328   has 'include' => (
 329       is      => 'rw',
 330       isa     => 'ArrayRef',
 331       default => sub { [] }
 332   );
 333
 334 would translate into C<includes=s@> as a Getopt::Long option descriptor,
 335 which would enable the following command line options:
 336
 337   % my_script.pl --include /usr/lib --include /usr/local/lib
 338
 339 =item I<HashRef>
 340
 341 A I<HashRef> type constraint is set up as a hash value option
 342 in Getopt::Long. So that this attribute description:
 343
 344   has 'define' => (
 345       is      => 'rw',
 346       isa     => 'HashRef',
 347       default => sub { {} }
 348   );
 349
 350 would translate into C<define=s%> as a Getopt::Long option descriptor,
 351 which would enable the following command line options:
 352
 353   % my_script.pl --define os=linux --define vendor=debian
 354
 355 =back
 356
 357 =head2 Custom Type Constraints
 358
 359 It is possible to create custom type constraint to option spec
 360 mappings if you need them. The process is fairly simple (but a
 361 little verbose maybe). First you create a custom subtype, like
 362 so:
 363
 364   subtype 'ArrayOfInts'
 365       => as 'ArrayRef'
 366       => where { scalar (grep { looks_like_number($_) } @$_)  };
 367
 368 Then you register the mapping, like so:
 369
 370   MooseX::Getopt::OptionTypeMap->add_option_type_to_map(
 371       'ArrayOfInts' => '=i@'
 372   );
 373
 374 Now any attribute declarations using this type constraint will
 375 get the custom option spec. So that, this:
 376
 377   has 'nums' => (
 378       is      => 'ro',
 379       isa     => 'ArrayOfInts',
 380       default => sub { [0] }
 381   );
 382
 383 Will translate to the following on the command line:
 384
 385   % my_script.pl --nums 5 --nums 88 --nums 199
 386
 387 This example is fairly trivial, but more complex validations are
 388 easily possible with a little creativity. The trick is balancing
 389 the type constraint validations with the Getopt::Long validations.
 390
 391 Better examples are certainly welcome :)
 392
 393 =head2 Inferred Type Constraints
 394
 395 If you define a custom subtype which is a subtype of one of the
 396 standard L</Supported Type Constraints> above, and do not explicitly
 397 provide custom support as in L</Custom Type Constraints> above,
 398 MooseX::Getopt will treat it like the parent type for Getopt
 399 purposes.
 400
 401 For example, if you had the same custom C<ArrayOfInts> subtype
 402 from the examples above, but did not add a new custom option
 403 type for it to the C<OptionTypeMap>, it would be treated just
 404 like a normal C<ArrayRef> type for Getopt purposes (that is,
 405 C<=s@>).
 406
 407 =head1 METHODS
 408
 409 =over 4
 410
 411 =item B<new_with_options (%params)>
 412
 413 This method will take a set of default C<%params> and then collect
 414 params from the command line (possibly overriding those in C<%params>)
 415 and then return a newly constructed object.
 416
 417 If L<Getopt::Long/GetOptions> fails (due to invalid arguments),
 418 C<new_with_options> will throw an exception.
 419
 420 If you have L<Getopt::Long::Descriptive> a the C<usage> param is also passed to
 421 C<new>.
 422
 423 =item B<ARGV>
 424
 425 This accessor contains a reference to a copy of the C<@ARGV> array
 426 as it originally existed at the time of C<new_with_options>.
 427
 428 =item B<extra_argv>
 429
 430 This accessor contains an arrayref of leftover C<@ARGV> elements that
 431 L<Getopt::Long> did not parse.  Note that the real C<@ARGV> is left
 432 un-mangled.
 433
 434 =item B<meta>
 435
 436 This returns the role meta object.
 437
 438 =back
 439
 440 =head1 BUGS
 441
 442 All complex software has bugs lurking in it, and this module is no
 443 exception. If you find a bug please either email me, or add the bug
 444 to cpan-RT.
 445
 446 =head1 AUTHOR
 447
 448 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 449
 450 Brandon L. Black, E<lt>blblack@gmail.comE<gt>
 451
 452 Yuval Kogman, E<lt>nothingmuch@woobling.orgE<gt>
 453
 454 =head1 CONTRIBUTORS
 455
 456 Ryan D Johnson, E<lt>ryan@innerfence.comE<gt>
 457
 458 =head1 COPYRIGHT AND LICENSE
 459
 460 Copyright 2007-2008 by Infinity Interactive, Inc.
 461
 462 L<http://www.iinteractive.com>
 463
 464 This library is free software; you can redistribute it and/or modify
 465 it under the same terms as Perl itself.
 466
 467 =cut