lib/MooseX/Getopt.pm

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