lib/MooseX/Getopt.pm

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