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