lib/MooseX/Getopt/Basic.pm

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