X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMooseX%2FGetopt.pm;h=27c17c8496eefd2e71629aa0d9969a12d20619af;hb=d09046450c54b37640fed28a06a17b7d040ba81a;hp=85747e540c72768f4f5f27a313b3418145bd4415;hpb=630657d529277b7fb600febf001d8667d8e85184;p=gitmo%2FMooseX-Getopt.git diff --git a/lib/MooseX/Getopt.pm b/lib/MooseX/Getopt.pm index 85747e5..27c17c8 100644 --- a/lib/MooseX/Getopt.pm +++ b/lib/MooseX/Getopt.pm @@ -2,224 +2,102 @@ package MooseX::Getopt; use Moose::Role; +use Moose::Util::TypeConstraints; + use MooseX::Getopt::OptionTypeMap; + +use MooseX::Getopt::Session; + 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.14'; +our $VERSION = '0.15'; 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) = @_; +use constant _default_getopt_session => 'MooseX::Getopt::Session'; - 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 ); +has getopt => ( + is => 'rw', + isa => 'MooseX::Getopt::Session', + metaclass => 'NoGetopt', + handles => [ 'ARGV', 'extra_argv' ], +); - 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 ]; +sub new_with_options { + my $class = shift; - my @err; + return $class->new( $class->get_options_from_argv(@_) ); +}; - 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 ); - } - }; +sub get_options_from_argv { + my $class = shift; - die join "", grep { defined } @err, $@ if @err or $@; + Moose->throw_error("Single parameters to get_options_from_argv() must be a HASH ref") + if ref $_[0] and ref $_ ne 'HASH'; - # Get a copy of the Getopt::Long-mangled @ARGV - my $argv_mangled = [ @ARGV ]; + my %params = ( $class->_get_options_from_configfile, @_ == 1 ? %{ $_[0] } : @_ ); - my %constructor_args = ( - map { - $name_to_init_arg->{$_} => $parsed_options->{$_} - } keys %$parsed_options, - ); + my $getopt = defined $params{getopt} + ? $params{getopt} + : $class->_default_getopt_session->new( + classes_filter => sub { $_ eq $class }, + params => \%params, + ); - return ( - params => \%constructor_args, - argv_copy => $argv_copy, - argv => $argv_mangled, - ( defined($usage) ? ( usage => $usage ) : () ), + my %new_params = ( + %{ $getopt->params }, # params from session object + %params, # explicit params to ->new + %{ $getopt->options }, # params from CLI + getopt => $getopt, ); -} - -sub _usage_format { - return "usage: %c %o"; -} - -sub _traditional_spec { - my ( $class, %params ) = @_; - my ( @options, %name_to_init_arg, %options ); + return %new_params; +}; - 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 _get_options_from_configfile { + my $class = shift; -sub _gld_spec { - my ( $class, %params ) = @_; + my %params = (); - my ( @options, %name_to_init_arg ); + if ($class->meta->does_role('MooseX::ConfigFromFile')) { + local @ARGV = @ARGV; - my $constructor_params = $params{params}; + my $configfile; + my $opt_parser = Getopt::Long::Parser->new( config => [ 'pass_through' ] ); + $opt_parser->getoptions( "configfile=s" => \$configfile ); - 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}) : () ), - }, - ]; + if (not defined $configfile) { + my $cfmeta = $class->meta->find_attribute_by_name('configfile'); + $configfile = $cfmeta->default if $cfmeta->has_default; + }; - my $identifier = $opt->{name}; - $identifier =~ s/\W/_/g; # Getopt::Long does this to all option names + if (defined $configfile) { + %params = %{ $class->get_config_from_file($configfile) }; + }; + }; - $name_to_init_arg{$identifier} = $opt->{init_arg}; - } + return %params; +}; - return ( \@options, \%name_to_init_arg ); -} sub _compute_getopt_attrs { my $class = shift; - grep { - $_->does("MooseX::Getopt::Meta::Attribute::Trait") + + return 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; + } $class->meta->compute_all_applicable_attributes; +}; - 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_name = $attr->type_constraint->name; - if (MooseX::Getopt::OptionTypeMap->has_option_type($type_name)) { - $opt_string .= MooseX::Getopt::OptionTypeMap->get_option_type($type_name) - } - } - - 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; @@ -404,6 +282,42 @@ type for it to the C, it would be treated just like a normal C type for Getopt purposes (that is, C<=s@>). +=head2 Session + +L can handle more than one class which contain +attributes filled from CLI. In this case, you need to use explicite +L object and then the Getopt attributes will be +searched in any class which does L. + + package My::App; + use Moose; + with 'MooseX::Getopt'; + has 'send' => (is => 'rw', predicate => 'has_send'); + + package My::App::Send; + use Moose; + with 'MooseX::Getopt'; + has 'to' => (is => 'rw', isa => 'Str', default => 'localhost'); + sub send { my $self = shift; warn "Sending mail to ", $self->to; } + + # ... rest of the class here + + ## in your script + #!/usr/bin/perl + + my $getopt = MooseX::Getopt::Session->new; + + my $app = My::App->new_with_options( getopt => $getopt ); + if ($app->has_send) { + # Use the same command line + my $sender = My::App::Send->new_with_options( getopt => $getopt ); + $sender->send; + } + # ... rest of the script here + + ## on the command line + % perl my_app_script.pl --send --to server.example.net + =head1 METHODS =over 4 @@ -420,10 +334,17 @@ C will throw an exception. If you have L a the C param is also passed to C. +=item B + +This method returns the list of parameters collected from command line +without creating the new object. + =item B -This accessor contains a reference to a copy of the C<@ARGV> array -as it originally existed at the time of C. +This accessor contains a reference to a copy of the C<@ARGV> array as it +originally existed at the time of C. + +The C is delegated from L object. =item B @@ -431,12 +352,32 @@ 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. +The C is delegated from L object. + +=item B + +This accessor contains a L object. This object can +be shared between more than one class which does L. The new +object is created by default. + =item B This returns the role meta object. =back +=head1 SEE ALSO + +=over 4 + +=item L + +=item L + +=item L + +=back + =head1 BUGS All complex software has bugs lurking in it, and this module is no @@ -455,6 +396,8 @@ Yuval Kogman, Enothingmuch@woobling.orgE Ryan D Johnson, Eryan@innerfence.comE +Piotr Roszatycki, Edexter@cpan.orgE + =head1 COPYRIGHT AND LICENSE Copyright 2007-2008 by Infinity Interactive, Inc.