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