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