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