X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMooseX%2FGetopt.pm;h=1f40e00f3728118c92ab7d01f84d27e2a3d8823b;hb=08ff0d657bba58a1c3a2792619f2213ccea649b5;hp=cdd78e7040d880d9985a5df5a1e984445ea63151;hpb=bff3807bb402a84be10c48d2e4d1be0628fde911;p=gitmo%2FMooseX-Getopt.git diff --git a/lib/MooseX/Getopt.pm b/lib/MooseX/Getopt.pm index cdd78e7..1f40e00 100644 --- a/lib/MooseX/Getopt.pm +++ b/lib/MooseX/Getopt.pm @@ -2,16 +2,18 @@ package MooseX::Getopt; use Moose::Role; -use Getopt::Long (); - use MooseX::Getopt::OptionTypeMap; use MooseX::Getopt::Meta::Attribute; +use MooseX::Getopt::Meta::Attribute::NoGetopt; + +use Getopt::Long (); # GLD uses it anyway, doesn't hurt +use constant HAVE_GLD => not not eval { require Getopt::Long::Descriptive }; -our $VERSION = '0.06'; +our $VERSION = '0.09'; our $AUTHORITY = 'cpan:STEVAN'; -has ARGV => (is => 'rw', isa => 'ArrayRef'); -has extra_argv => (is => 'rw', isa => 'ArrayRef'); +has ARGV => (is => 'rw', isa => 'ArrayRef', documentation => "hidden"); +has extra_argv => (is => 'rw', isa => 'ArrayRef', documentation => "hidden"); sub new_with_options { my ($class, @params) = @_; @@ -22,11 +24,21 @@ sub new_with_options { ] ); + my $params = $processed{params}; + + if($class->meta->does_role('MooseX::ConfigFromFile') + && defined $params->{configfile}) { + %$params = ( + %{$class->get_config_from_file($params->{configfile})}, + %$params, + ); + } + $class->new( ARGV => $processed{argv_copy}, extra_argv => $processed{argv}, @params, # explicit params to ->new - %{ $processed{params} }, # params from CLI + %$params, # params from CLI ); } @@ -35,44 +47,90 @@ sub _parse_argv { local @ARGV = @{ $params{argv} || \@ARGV }; - my ( @options, %name_to_init_arg, %options ); - - foreach my $opt ( @{ $params{options} } ) { - push @options, $opt->{opt_string}; - $name_to_init_arg{ $opt->{name} } = $opt->{init_arg}; - } + 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 ]; - { - local $SIG{__WARN__} = sub { die $_[0] }; - Getopt::Long::GetOptions(\%options, @options); - } + 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, - params => { - map { - $name_to_init_arg{$_} => $options{$_} - } keys %options, - } + ( 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}; + $name_to_init_arg{ $opt->{name} } = $opt->{init_arg}; + } + + return ( \@options, \%name_to_init_arg ); +} + +sub _gld_spec { + my ( $class, %params ) = @_; + + my ( @options, %name_to_init_arg ); + + foreach my $opt ( @{ $params{options} } ) { + push @options, [ + $opt->{opt_string}, + $opt->{doc} || ' ', # FIXME new GLD shouldn't need this hack + { + ( $opt->{required} ? (required => $opt->{required}) : () ), + ( exists $opt->{default} ? (default => $opt->{default}) : () ), + }, + ]; + + $name_to_init_arg{ $opt->{name} } = $opt->{init_arg}; + } + + return ( \@options, \%name_to_init_arg ); +} + sub _compute_getopt_attrs { my $class = shift; - grep { $_->isa("MooseX::Getopt::Meta::Attribute") or $_->name !~ /^_/ && - !$_->isa('MooseX::Getopt::Meta::NoGetopt') + !$_->isa('MooseX::Getopt::Meta::Attribute::NoGetopt') } $class->meta->compute_all_applicable_attributes } @@ -97,8 +155,8 @@ sub _attrs_to_options { if ($attr->has_type_constraint) { my $type_name = $attr->type_constraint->name; - if (MooseX::Getopt::OptionTypeMap->has_option_type($type_name)) { - $opt_string .= MooseX::Getopt::OptionTypeMap->get_option_type($type_name); + if (MooseX::Getopt::OptionTypeMap->has_option_type($type_name)) { + $opt_string .= MooseX::Getopt::OptionTypeMap->get_option_type($type_name) } } @@ -107,6 +165,7 @@ sub _attrs_to_options { init_arg => $attr->init_arg, opt_string => $opt_string, required => $attr->is_required, + ( ( $attr->has_default && ( $attr->is_default_a_coderef xor $attr->is_lazy ) ) ? ( default => $attr->default({}) ) : () ), ( $attr->has_documentation ? ( doc => $attr->documentation ) : () ), } } @@ -162,6 +221,9 @@ accordingly. You can use the attribute metaclass L to get non-default commandline option names and aliases. +You can use the attribute metaclass L +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 @@ -176,6 +238,11 @@ to have the leading underscore in thier name, you can do this: This will mean that Getopt will not handle a --foo param, but your code can still call the C method. +If your class also uses a configfile-loading role based on +L, such as L, +L's C will load the configfile +specified by the C<--configfile> option for you. + =head2 Supported Type Constraints =over 4 @@ -295,6 +362,9 @@ and then return a newly constructed object. If L fails (due to invalid arguments), C will throw an exception. +If you have L a the C param is also passed to +C. + =item B This accessor contains a reference to a copy of the C<@ARGV> array