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=e57c141b9d61806c38080efab0d1f18b3241c397;hp=74b8be02320a10f322243986847eb989567e9874;hb=30ed85f7fc94f619d46a7430aff840b334c0ebce;hpb=f4308031a6f638c55439e3071af124f79eacd2ca diff --git a/lib/MooseX/Getopt.pm b/lib/MooseX/Getopt.pm index 74b8be0..e57c141 100644 --- a/lib/MooseX/Getopt.pm +++ b/lib/MooseX/Getopt.pm @@ -2,227 +2,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 Getopt::Long (); # GLD uses it anyway, doesn't hurt use constant HAVE_GLD => not not eval { require Getopt::Long::Descriptive }; -our $VERSION = '0.18'; -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 @roles = ('MooseX::Getopt::Basic'); +if (HAVE_GLD()) { push @roles, 'MooseX::Getopt::GLD' } - 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; -} +with @roles; no Moose::Role; 1; @@ -417,9 +202,24 @@ 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>. + +The paramater C, if specified and a true value will disable +the use of L . + If L fails (due to invalid arguments), C will throw an exception. +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 a the C param is also passed to C. @@ -438,6 +238,10 @@ un-mangled. This returns the role meta object. +=item B + +A constant for internal use. + =back =head1 BUGS @@ -458,6 +262,8 @@ Yuval Kogman, Enothingmuch@woobling.orgE Ryan D Johnson, Eryan@innerfence.comE +Drew Taylor, Edrew@drewtaylor.comE + =head1 COPYRIGHT AND LICENSE Copyright 2007-2008 by Infinity Interactive, Inc.