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