From: Brandon L Black Date: Tue, 22 May 2007 23:55:39 +0000 (+0000) Subject: Throw exceptions from new_with_options if @ARGV parsing fails X-Git-Tag: 0_04~1 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f63e631037a9d743d874ae465e8b0a8d541c16c2;p=gitmo%2FMooseX-Getopt.git Throw exceptions from new_with_options if @ARGV parsing fails Restore the mangled @ARGV to its original state after Getopt is done Added ->extra_argv accessor for the Getopt leftovers Added subtype constraint inference Added docs/tests/ChangeLog for all of the above --- diff --git a/ChangeLog b/ChangeLog index 623594e..a3db017 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,18 @@ 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 @@ -26,4 +39,4 @@ Revision history for Perl extension MooseX-Getopt - 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 diff --git a/lib/MooseX/Getopt.pm b/lib/MooseX/Getopt.pm index 229b2be..666ef15 100644 --- a/lib/MooseX/Getopt.pm +++ b/lib/MooseX/Getopt.pm @@ -2,7 +2,7 @@ package MooseX::Getopt; use Moose::Role; -use Getopt::Long; +use Getopt::Long (); use MooseX::Getopt::OptionTypeMap; use MooseX::Getopt::Meta::Attribute; @@ -10,7 +10,8 @@ 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) = @_; @@ -45,10 +46,21 @@ sub new_with_options { 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; @@ -56,7 +68,8 @@ sub new_with_options { #warn Dumper \%options; $class->new( - ARGV => $saved_argv, + ARGV => $argv_copy, + extra_argv => $argv_mangled, %params, map { $name_to_init_arg{$_} => $options{$_} @@ -218,6 +231,20 @@ the type constraint validations with the Getopt::Long validations. 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 above, and do not explicitly +provide custom support as in L above, +MooseX::Getopt will treat it like the parent type for Getopt +purposes. + +For example, if you had the same custom C subtype +from the examples above, but did not add a new custom option +type for it to the C, it would be treated just +like a normal C type for Getopt purposes (that is, +C<=s@>). + =head1 METHODS =over 4 @@ -228,11 +255,19 @@ This method will take a set of default C<%params> and then collect params from the command line (possibly overriding those in C<%params>) and then return a newly constructed object. +If L fails (due to invalid arguments), +C will throw an exception. + =item B This accessor contains a reference to a copy of the C<@ARGV> array -which was copied before L mangled it, in case you want -to see your original options. +as it originally existed at the time of C. + +=item B + +This accessor contains an arrayref of leftover C<@ARGV> elements that +L did not parse. Note that the real C<@ARGV> is left +un-mangled. =item B diff --git a/lib/MooseX/Getopt/OptionTypeMap.pm b/lib/MooseX/Getopt/OptionTypeMap.pm index a443d9d..69ac55e 100644 --- a/lib/MooseX/Getopt/OptionTypeMap.pm +++ b/lib/MooseX/Getopt/OptionTypeMap.pm @@ -16,8 +16,34 @@ my %option_type_map = ( '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) @@ -76,4 +102,4 @@ L 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 diff --git a/t/001_basic.t b/t/001_basic.t index 7ffbe5b..55cba23 100644 --- a/t/001_basic.t +++ b/t/001_basic.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 51; +use Test::More tests => 53; BEGIN { use_ok('MooseX::Getopt'); @@ -206,9 +206,11 @@ BEGIN { # 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'); } diff --git a/t/002_custom_option_type.t b/t/002_custom_option_type.t index 881b0f6..fc46250 100644 --- a/t/002_custom_option_type.t +++ b/t/002_custom_option_type.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 5; +use Test::More tests => 6; BEGIN { use_ok('MooseX::Getopt'); @@ -52,3 +52,12 @@ BEGIN { 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'); diff --git a/t/003_inferred_option_type.t b/t/003_inferred_option_type.t new file mode 100644 index 0000000..5624867 --- /dev/null +++ b/t/003_inferred_option_type.t @@ -0,0 +1,50 @@ +#!/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'); +} +