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