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