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