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