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