From: Tomas Doran Date: Sun, 30 Aug 2009 16:19:49 +0000 (+0100) Subject: Merge master into branch X-Git-Tag: 0.22~4 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMooseX-Getopt.git;a=commitdiff_plain;h=refs%2Fheads%2Ftopic%2Fsplit_gld_from_basic;hp=ff71d314a11f54b1da6c6aa7b04009bd5b6cc96d Merge master into branch --- diff --git a/ChangeLog b/ChangeLog index a23201b..6d48eec 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,13 +1,19 @@ Revision history for Perl extension MooseX-Getopt - * MooseX::Getopt - - Enable and document the argv parameter to the constructor. +0.22 * MooseX::Getopt - Split into MooseX::Getopt::Basic (without the G::L::Descriptive support) and MooseX::Getopt::GLD. +0.21 Thu. Aug 27 2009 + * MooseX::Getopt + - Enable and document the argv parameter to the constructor. + - Applied patches in RT43200 and RT43255 + - Applied patch from RT#47766 to not die if SimpleConfig cannot find the + default config file name. + 0.20 Wed. July 9 2009 - ~ fix MANIFEST.SKIP to avoid double-packaging + - fix MANIFEST.SKIP to avoid double-packaging 0.19 Wed. July 8 2009 * MooseX::Getopt @@ -20,12 +26,12 @@ Revision history for Perl extension MooseX-Getopt - Fix tests on Win32 from RT#44909 (taro-nishino) 0.18 Thu. April 9 2009 - * MooseX::Getopt::Dashes - - New module, for converting undercores to dashes (ilmari) + * MooseX::Getopt::Dashes + - New module, for converting undercores to dashes (ilmari) 0.17 Wed. April 8 2009 * MooseX::Getopt - - work with latest Moose (hdp) + - work with latest Moose (hdp) ~ unify module version numbers with dist version (hdp) diff --git a/Makefile.PL b/Makefile.PL index 681fd58..d9d0041 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -11,10 +11,12 @@ requires 'Getopt::Long' => '2.37'; # optional requires 'Getopt::Long::Descriptive' => 0; +build_requires 'Test::Moose'; build_requires 'Test::More' => '0.62'; build_requires 'Test::Exception' => '0.21'; -tests_recursive(); +resources repository => 'git://git.moose.perl.org/MooseX-Getopt.git'; + auto_manifest(); WriteAll; diff --git a/README b/README index 5c6b104..ce181ae 100644 --- a/README +++ b/README @@ -1,4 +1,4 @@ -MooseX::Getopt version 0.20 +MooseX::Getopt version 0.21 =========================== See the individual module documentation for more information diff --git a/lib/MooseX/Getopt.pm b/lib/MooseX/Getopt.pm index d8b5d2b..4550082 100644 --- a/lib/MooseX/Getopt.pm +++ b/lib/MooseX/Getopt.pm @@ -2,15 +2,240 @@ package MooseX::Getopt; use Moose::Role; -our $VERSION = '0.20'; -our $AUTHORITY = 'cpan:STEVAN'; +use MooseX::Getopt::OptionTypeMap; +use MooseX::Getopt::Meta::Attribute; +use MooseX::Getopt::Meta::Attribute::NoGetopt; + +use Carp (); +use Getopt::Long (); # GLD uses it anyway, doesn't hurt use constant HAVE_GLD => not not eval { require Getopt::Long::Descriptive }; -my @roles = ('MooseX::Getopt::Basic'); -if (HAVE_GLD()) { push @roles, 'MooseX::Getopt::GLD' } +our $VERSION = '0.21'; +our $AUTHORITY = 'cpan:STEVAN'; -with @roles; +has ARGV => (is => 'rw', isa => 'ArrayRef', metaclass => "NoGetopt"); +has extra_argv => (is => 'rw', isa => 'ArrayRef', metaclass => "NoGetopt"); + +sub new_with_options { + my ($class, @params) = @_; + + my $config_from_file; + if($class->meta->does_role('MooseX::ConfigFromFile')) { + local @ARGV = @ARGV; + + my $configfile; + my $opt_parser = Getopt::Long::Parser->new( config => [ qw( pass_through ) ] ); + $opt_parser->getoptions( "configfile=s" => \$configfile ); + + if(!defined $configfile) { + my $cfmeta = $class->meta->find_attribute_by_name('configfile'); + $configfile = $cfmeta->default if $cfmeta->has_default; + if (defined $configfile) { + $config_from_file = eval { + $class->get_config_from_file($configfile); + }; + if ($@) { + die $@ unless $@ =~ /Specified configfile '\Q$configfile\E' does not exist/; + } + } + } + else { + $config_from_file = $class->get_config_from_file($configfile); + } + } + + my $constructor_params = ( @params == 1 ? $params[0] : {@params} ); + + Carp::croak("Single parameters to new_with_options() must be a HASH ref") + unless ref($constructor_params) eq 'HASH'; + + my %processed = $class->_parse_argv( + options => [ + $class->_attrs_to_options( $config_from_file ) + ], + params => $constructor_params, + ); + + my $params = $config_from_file ? { %$config_from_file, %{$processed{params}} } : $processed{params}; + + # did the user request usage information? + if ( $processed{usage} && ($params->{'?'} or $params->{help} or $params->{usage}) ) + { + $processed{usage}->die(); + } + + $class->new( + ARGV => $processed{argv_copy}, + extra_argv => $processed{argv}, + %$constructor_params, # explicit params to ->new + %$params, # params from CLI + ); +} + +sub _parse_argv { + my ( $class, %params ) = @_; + + local @ARGV = @{ $params{params}{argv} || \@ARGV }; + + my ( $opt_spec, $name_to_init_arg ) = ( HAVE_GLD ? $class->_gld_spec(%params) : $class->_traditional_spec(%params) ); + + # Get a clean copy of the original @ARGV + my $argv_copy = [ @ARGV ]; + + my @err; + + my ( $parsed_options, $usage ) = eval { + local $SIG{__WARN__} = sub { push @err, @_ }; + + if ( HAVE_GLD ) { + return Getopt::Long::Descriptive::describe_options($class->_usage_format(%params), @$opt_spec); + } else { + my %options; + Getopt::Long::GetOptions(\%options, @$opt_spec); + return ( \%options, undef ); + } + }; + + die join "", grep { defined } @err, $@ if @err or $@; + + # Get a copy of the Getopt::Long-mangled @ARGV + my $argv_mangled = [ @ARGV ]; + + my %constructor_args = ( + map { + $name_to_init_arg->{$_} => $parsed_options->{$_} + } keys %$parsed_options, + ); + + return ( + params => \%constructor_args, + argv_copy => $argv_copy, + argv => $argv_mangled, + ( defined($usage) ? ( usage => $usage ) : () ), + ); +} + +sub _usage_format { + return "usage: %c %o"; +} + +sub _traditional_spec { + my ( $class, %params ) = @_; + + my ( @options, %name_to_init_arg, %options ); + + foreach my $opt ( @{ $params{options} } ) { + push @options, $opt->{opt_string}; + + my $identifier = $opt->{name}; + $identifier =~ s/\W/_/g; # Getopt::Long does this to all option names + + $name_to_init_arg{$identifier} = $opt->{init_arg}; + } + + return ( \@options, \%name_to_init_arg ); +} + +sub _gld_spec { + my ( $class, %params ) = @_; + + my ( @options, %name_to_init_arg ); + + my $constructor_params = $params{params}; + + foreach my $opt ( @{ $params{options} } ) { + push @options, [ + $opt->{opt_string}, + $opt->{doc} || ' ', # FIXME new GLD shouldn't need this hack + { + ( ( $opt->{required} && !exists($constructor_params->{$opt->{init_arg}}) ) ? (required => $opt->{required}) : () ), + # NOTE: + # remove this 'feature' because it didn't work + # all the time, and so is better to not bother + # since Moose will handle the defaults just + # fine anyway. + # - SL + #( exists $opt->{default} ? (default => $opt->{default}) : () ), + }, + ]; + + my $identifier = $opt->{name}; + $identifier =~ s/\W/_/g; # Getopt::Long does this to all option names + + $name_to_init_arg{$identifier} = $opt->{init_arg}; + } + + return ( \@options, \%name_to_init_arg ); +} + +sub _compute_getopt_attrs { + my $class = shift; + grep { + $_->does("MooseX::Getopt::Meta::Attribute::Trait") + or + $_->name !~ /^_/ + } grep { + !$_->does('MooseX::Getopt::Meta::Attribute::Trait::NoGetopt') + } $class->meta->get_all_attributes +} + +sub _get_cmd_flags_for_attr { + my ( $class, $attr ) = @_; + + my $flag = $attr->name; + + my @aliases; + + if ($attr->does('MooseX::Getopt::Meta::Attribute::Trait')) { + $flag = $attr->cmd_flag if $attr->has_cmd_flag; + @aliases = @{ $attr->cmd_aliases } if $attr->has_cmd_aliases; + } + + return ( $flag, @aliases ); +} + +sub _attrs_to_options { + my $class = shift; + my $config_from_file = shift || {}; + + my @options; + + foreach my $attr ($class->_compute_getopt_attrs) { + my ( $flag, @aliases ) = $class->_get_cmd_flags_for_attr($attr); + + my $opt_string = join(q{|}, $flag, @aliases); + + if ($attr->name eq 'configfile') { + $opt_string .= '=s'; + } + elsif ($attr->has_type_constraint) { + my $type = $attr->type_constraint; + if (MooseX::Getopt::OptionTypeMap->has_option_type($type)) { + $opt_string .= MooseX::Getopt::OptionTypeMap->get_option_type($type) + } + } + + push @options, { + name => $flag, + init_arg => $attr->init_arg, + opt_string => $opt_string, + required => $attr->is_required && !$attr->has_default && !$attr->has_builder && !exists $config_from_file->{$attr->name}, + # NOTE: + # this "feature" was breaking because + # Getopt::Long::Descriptive would return + # the default value as if it was a command + # line flag, which would then override the + # one passed into a constructor. + # See 100_gld_default_bug.t for an example + # - SL + #( ( $attr->has_default && ( $attr->is_default_a_coderef xor $attr->is_lazy ) ) ? ( default => $attr->default({}) ) : () ), + ( $attr->has_documentation ? ( doc => $attr->documentation ) : () ), + } + } + + return @options; +} no Moose::Role; 1; @@ -67,8 +292,8 @@ to have C ignore your attribute in the commandline options. By default, attributes which start with an underscore are not given commandline argument support, unless the attribute's metaclass is set -to L. If you don't want you accessors -to have the leading underscore in thier name, you can do this: +to L. If you don't want your accessors +to have the leading underscore in their name, you can do this: # for read/write attributes has '_foo' => (accessor => 'foo', ...); @@ -220,7 +445,7 @@ B option for each attribute to document. --help --usage -If you have L a the C param is also passed to +If you have L the C param is also passed to C. =item B @@ -238,10 +463,6 @@ un-mangled. This returns the role meta object. -=item B - -A constant for internal use. - =back =head1 BUGS diff --git a/lib/MooseX/Getopt/Basic.pm b/lib/MooseX/Getopt/Basic.pm index 88fa48b..453b913 100644 --- a/lib/MooseX/Getopt/Basic.pm +++ b/lib/MooseX/Getopt/Basic.pm @@ -44,8 +44,13 @@ sub new_with_options { $configfile = $cfmeta->default if $cfmeta->has_default; } - if(defined $configfile) { - $config_from_file = $class->get_config_from_file($configfile); + if (defined $configfile) { + $config_from_file = eval { + $class->get_config_from_file($configfile); + }; + if ($@) { + die $@ unless $@ =~ /Specified configfile '\Q$configfile\E' does not exist/; + } } }