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