X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMooseX-Getopt.git;a=blobdiff_plain;f=lib%2FMooseX%2FGetopt.pm;h=4f1903be4ee49d7674b81a4b47ab3f68ad4cf198;hp=541706ac840808766537d275d151b71ce6de77ec;hb=66c33c2890cfab766f7b9274dd7893a12a258d6b;hpb=e4ab19b9445dcf65ee157b92616946863ee7274b diff --git a/lib/MooseX/Getopt.pm b/lib/MooseX/Getopt.pm index 541706a..4f1903b 100644 --- a/lib/MooseX/Getopt.pm +++ b/lib/MooseX/Getopt.pm @@ -1,225 +1,12 @@ - package MooseX::Getopt; use Moose::Role; -use MooseX::Getopt::OptionTypeMap; -use MooseX::Getopt::Meta::Attribute; -use MooseX::Getopt::Meta::Attribute::NoGetopt; - -use Carp (); +use constant _HAVE_GLD => not not eval { require Getopt::Long::Descriptive }; -use Getopt::Long (); # GLD uses it anyway, doesn't hurt -use constant HAVE_GLD => not not eval { require Getopt::Long::Descriptive }; - -our $VERSION = '0.15'; +our $VERSION = '0.25'; our $AUTHORITY = 'cpan:STEVAN'; -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 = $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}; - - $class->new( - ARGV => $processed{argv_copy}, - extra_argv => $processed{argv}, - @params, # explicit params to ->new - %$params, # params from CLI - ); -} - -sub _parse_argv { - my ( $class, %params ) = @_; - - local @ARGV = @{ $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->compute_all_applicable_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->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; -} +with _HAVE_GLD ? 'MooseX::Getopt::GLD' : 'MooseX::Getopt::Basic'; no Moose::Role; 1; @@ -276,8 +63,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', ...); @@ -414,10 +201,22 @@ 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. +The special parameter C, if specified should point to an array +reference with an array to use instead of C<@ARGV>. + If L fails (due to invalid arguments), C will throw an exception. -If you have L a the C param is also passed to +If L is installed and any of the following +command line params are passed, the program will exit with usage +information. You can add descriptions for each option by including a +B option for each attribute to document. + + --? + --help + --usage + +If you have L the C param is also passed to C. =item B @@ -455,6 +254,10 @@ Yuval Kogman, Enothingmuch@woobling.orgE Ryan D Johnson, Eryan@innerfence.comE +Drew Taylor, Edrew@drewtaylor.comE + +Tomas Doran, (t0m) C<< >> + =head1 COPYRIGHT AND LICENSE Copyright 2007-2008 by Infinity Interactive, Inc.