Revision history for Perl extension MooseX-Getopt
+ * MooseX::Getopt::OptionTypeMap
+ - Added support for subtype constraint inference
+ from parent types
+ - added tests and docs for this
+ * MooseX::Getopt
+ - Added extra_argv attribute
+ - added tests and docs for this
+ - We now unmangled the Getopt::Long-manged @ARGV
+ - added tests and docs for this
+ - We now throw an exception from new_with_options
+ if Getopt fails due to bad arguments.
+ - added tests and docs for this
+
0.03 Wed. May 2nd, 2007
~ downgraded the Getopt version requirement
to 2.35 as per RT #26844
- added tests and docs for this
0.01 Friday, March 9, 2007
- - module released to CPAN
\ No newline at end of file
+ - module released to CPAN
package MooseX::Getopt;
use Moose::Role;
-use Getopt::Long;
+use Getopt::Long ();
use MooseX::Getopt::OptionTypeMap;
use MooseX::Getopt::Meta::Attribute;
our $VERSION = '0.03';
our $AUTHORITY = 'cpan:STEVAN';
-has ARGV => (is => 'rw', isa => 'ArrayRef');
+has ARGV => (is => 'rw', isa => 'ArrayRef');
+has extra_argv => (is => 'rw', isa => 'ArrayRef');
sub new_with_options {
my ($class, %params) = @_;
push @options => $opt_string;
}
- my $saved_argv = [ @ARGV ];
my %options;
-
- GetOptions(\%options, @options);
+
+ # Get a clean copy of the original @ARGV
+ my $argv_copy = [ @ARGV ];
+
+ {
+ local $SIG{__WARN__} = sub { die $_[0] };
+ Getopt::Long::GetOptions(\%options, @options);
+ }
+
+ # Get a copy of the Getopt::Long-mangled @ARGV
+ my $argv_mangled = [ @ARGV ];
+
+ # Restore the original @ARGV;
+ @ARGV = @$argv_copy;
#use Data::Dumper;
#warn Dumper \@options;
#warn Dumper \%options;
$class->new(
- ARGV => $saved_argv,
+ ARGV => $argv_copy,
+ extra_argv => $argv_mangled,
%params,
map {
$name_to_init_arg{$_} => $options{$_}
Better examples are certainly welcome :)
+=head2 Inferred Type Constraints
+
+If you define a custom subtype which is a subtype of one of the
+standard L</Supported Type Constraints> above, and do not explicitly
+provide custom support as in L</Custom Type Constraints> above,
+MooseX::Getopt will treat it like the parent type for Getopt
+purposes.
+
+For example, if you had the same custom C<ArrayOfInts> subtype
+from the examples above, but did not add a new custom option
+type for it to the C<OptionTypeMap>, it would be treated just
+like a normal C<ArrayRef> type for Getopt purposes (that is,
+C<=s@>).
+
=head1 METHODS
=over 4
params from the command line (possibly overriding those in C<%params>)
and then return a newly constructed object.
+If L<Getopt::Long/GetOptions> fails (due to invalid arguments),
+C<new_with_options> will throw an exception.
+
=item B<ARGV>
This accessor contains a reference to a copy of the C<@ARGV> array
-which was copied before L<Getopt::Long> mangled it, in case you want
-to see your original options.
+as it originally existed at the time of C<new_with_options>.
+
+=item B<extra_argv>
+
+This accessor contains an arrayref of leftover C<@ARGV> elements that
+L<Getopt::Long> did not parse. Note that the real C<@ARGV> is left
+un-mangled.
=item B<meta>
'HashRef' => '=s%',
);
-sub has_option_type { exists $option_type_map{$_[1]} }
-sub get_option_type { $option_type_map{$_[1]} }
+sub has_option_type {
+ my (undef, $type_name) = @_;
+ return 1 if exists $option_type_map{$type_name};
+
+ my $current = find_type_constraint($type_name);
+ while (my $parent = $current->parent) {
+ return 1 if exists $option_type_map{$parent->name};
+ $current = $parent;
+ }
+
+ return 0;
+}
+
+sub get_option_type {
+ my (undef, $type_name) = @_;
+ return $option_type_map{$type_name}
+ if exists $option_type_map{$type_name};
+
+ my $current = find_type_constraint($type_name);
+ while (my $parent = $current->parent) {
+ return $option_type_map{$parent->name}
+ if exists $option_type_map{$parent->name};
+ $current = $parent;
+ }
+
+ return;
+}
+
sub add_option_type_to_map {
my (undef, $type_name, $option_string) = @_;
(defined $type_name && defined $option_string)
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
-=cut
\ No newline at end of file
+=cut
use strict;
use warnings;
-use Test::More tests => 51;
+use Test::More tests => 53;
BEGIN {
use_ok('MooseX::Getopt');
# Test ARGV support
{
- my @args = ('-p', 12345, '-c', 99);
+ my @args = ('-p', 12345, '-c', 99, '-');
local @ARGV = @args;
my $app = App->new_with_options;
isa_ok($app, 'App');
- is_deeply($app->ARGV, \@args);
+ is_deeply($app->ARGV, \@args, 'ARGV accessor');
+ is_deeply(\@ARGV, \@args, '@ARGV unmangled');
+ is_deeply($app->extra_argv, ['-'], 'extra_argv accessor');
}
use strict;
use warnings;
-use Test::More tests => 5;
+use Test::More tests => 6;
BEGIN {
use_ok('MooseX::Getopt');
is_deeply($app->nums, [3, 5], '... nums is [3, 5] as expected');
}
+# Make sure it really used our =i@, instead of falling back
+# to =s@ via the type system, and test that exceptions work
+# while we're at it.
+eval {
+ local @ARGV = ('--nums', 3, '--nums', 'foo');
+
+ my $app = App->new_with_options;
+};
+like($@, qr/Value "foo" invalid/, 'Numeric constraint enforced');
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 5;
+
+BEGIN {
+ use_ok('MooseX::Getopt');
+}
+
+{
+ package App;
+ use Moose;
+ use Moose::Util::TypeConstraints;
+
+ use Scalar::Util 'looks_like_number';
+
+ with 'MooseX::Getopt';
+
+ subtype 'ArrayOfInts'
+ => as 'ArrayRef'
+ => where { scalar (grep { looks_like_number($_) } @$_) };
+
+ has 'nums' => (
+ is => 'ro',
+ isa => 'ArrayOfInts',
+ default => sub { [0] }
+ );
+
+}
+
+{
+ local @ARGV = ();
+
+ my $app = App->new_with_options;
+ isa_ok($app, 'App');
+
+ is_deeply($app->nums, [0], '... nums is [0] as expected');
+}
+
+{
+ local @ARGV = ('--nums', 3, '--nums', 5);
+
+ my $app = App->new_with_options;
+ isa_ok($app, 'App');
+
+ is_deeply($app->nums, [3, 5], '... nums is [3, 5] as expected');
+}
+
projects / gitmo/MooseX-Getopt.git / commitdiff