lib/MooseX/Getopt.pm

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