From: Piotr Roszatycki Date: Mon, 10 Nov 2008 23:15:57 +0000 (+0000) Subject: * MooseX::Getopt X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c6c1f6285c8ad44ddb2375289ea449705bb467ad;p=gitmo%2FMooseX-Getopt.git * MooseX::Getopt * MooseX::Getopt::Session - MooseX::Getopt can start new Getopt session or get it as parameter (dexter) * MooseX::Getopt::Parser * MooseX::Getopt::Parser::Long * MooseX::Getopt::Parser::Descriptive - Getopt parser is pluggined. (dexter) * TODO: - MooseX::Getopt::Parser::Descriptive is not implemeted yet. - MooseX::ConfigFromFile should be restored? - POD. - New test units. --- diff --git a/ChangeLog b/ChangeLog index 96b8290..5cf2dd7 100644 --- a/ChangeLog +++ b/ChangeLog @@ -5,12 +5,22 @@ Revision history for Perl extension MooseX-Getopt - Use Moose's throw_error() method. (dexter) * MooseX::Getopt + * MooseX::Getopt::Session + - MooseX::Getopt can start new Getopt session or get it as parameter + (dexter) + * MooseX::Getopt::Parser * MooseX::Getopt::Parser::Long * MooseX::Getopt::Parser::Descriptive - - Handling with Getopt parser implemented as strategy pattern. + - Getopt parser is pluggined. (dexter) + * TODO: + - MooseX::Getopt::Parser::Descriptive is not implemeted yet. + - MooseX::ConfigFromFile should be restored? + - POD. + - New test units. + 0.15 Sat. July 26 2008 * MooseX::Getopt::OptionTypeMap - Accept type constraint objects in the type mapping, not just names diff --git a/lib/MooseX/Getopt.pm b/lib/MooseX/Getopt.pm index 3a087cf..a915d5a 100644 --- a/lib/MooseX/Getopt.pm +++ b/lib/MooseX/Getopt.pm @@ -6,8 +6,7 @@ use Moose::Util::TypeConstraints; use MooseX::Getopt::OptionTypeMap; -use MooseX::Getopt::Parser::Long; -use maybe 'MooseX::Getopt::Parser::Descriptive'; +use MooseX::Getopt::Session; use MooseX::Getopt::Meta::Attribute; use MooseX::Getopt::Meta::Attribute::NoGetopt; @@ -17,6 +16,9 @@ our $VERSION = '0.15'; our $AUTHORITY = 'cpan:STEVAN'; +use constant _default_getopt_session => 'MooseX::Getopt::Session'; + + has ARGV => ( is => 'rw', isa => 'ArrayRef', @@ -29,170 +31,49 @@ has extra_argv => ( metaclass => 'NoGetopt', ); -has getopt_parser => ( +has getopt => ( is => 'rw', - does => 'MooseX::Getopt::Parser', + isa => 'MooseX::Getopt::Session', metaclass => 'NoGetopt', ); -sub new_with_options { - my ($class, @params) = @_; - - my $config_from_file; - - my $constructor_params = ( @params == 1 ? $params[0] : {@params} ); - - my $getopt_parser; - if (defined $constructor_params->{getopt_parser}) { - $getopt_parser = $constructor_params->{getopt_parser}; - $getopt_parser = $getopt_parser->new if not ref $getopt_parser; - } - else { - $getopt_parser = maybe::HAVE_MOOSEX_GETOPT_PARSER_DESCRIPTIVE - ? MooseX::Getopt::Parser::Descriptive->new - : MooseX::Getopt::Parser::Long->new; - } - - 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); - } - } - - $class->throw_error("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, - getopt_parser => $getopt_parser, - ); - - my $params = $config_from_file ? { %$config_from_file, %{$processed{params}} } : $processed{params}; - - $class->new( - ARGV => $processed{argv_copy}, - extra_argv => $processed{argv}, - getopt_parser => $getopt_parser, - @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 ) = ( $params{getopt_parser}->_get_getopt_spec(%params) ); - - # Get a clean copy of the original @ARGV - my $argv_copy = [ @ARGV ]; - my @err; +sub new_with_options { + my $class = shift; - my ( $parsed_options, $usage ) = eval { - local $SIG{__WARN__} = sub { push @err, @_ }; + Moose->throw_error("Single parameters to new_with_options() must be a HASH ref") + if ref $_[0] and ref $_ ne 'HASH'; - return $params{getopt_parser}->getoptions($opt_spec); - }; + my %params = ( @_ == 1 ? %{ $_[0] } : @_ ); - die join "", grep { defined } @err, $@ if @err or $@; + my $getopt = defined $params{getopt} + ? $params{getopt} + : $class->_default_getopt_session->new; - # Get a copy of the Getopt::Long-mangled @ARGV - my $argv_mangled = [ @ARGV ]; + my %options = $getopt->options; - my %constructor_args = ( - map { - $name_to_init_arg->{$_} => $parsed_options->{$_} - } keys %$parsed_options, + $class->new( + ARGV => [ $getopt->argv ], # backward compatibility + extra_argv => [ $getopt->extra_argv ], # backward compatibility + getopt => $getopt, + %params, # explicit params to ->new + %options, # params from CLI ); +}; - return ( - params => \%constructor_args, - argv_copy => $argv_copy, - argv => $argv_mangled, - ( defined($usage) ? ( usage => $usage ) : () ), - ); -} 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 ) = @_; + } $class->meta->compute_all_applicable_attributes; +}; - 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; -} no Moose::Role; 1; diff --git a/lib/MooseX/Getopt/Meta/Attribute/Trait.pm b/lib/MooseX/Getopt/Meta/Attribute/Trait.pm index 024cdd1..b2eb96c 100644 --- a/lib/MooseX/Getopt/Meta/Attribute/Trait.pm +++ b/lib/MooseX/Getopt/Meta/Attribute/Trait.pm @@ -6,12 +6,25 @@ use Moose::Util::TypeConstraints; our $VERSION = '0.01'; our $AUTHORITY = 'cpan:STEVAN'; +has 'cmd_name' => ( + is => 'rw', + isa => 'Str', + predicate => 'has_cmd_name', +); + +# TODO: should be removed - it loses Getopt abstraction has 'cmd_flag' => ( is => 'rw', isa => 'Str', predicate => 'has_cmd_flag', ); +has 'cmd_type' => ( + is => 'rw', + isa => 'Str', + predicate => 'has_cmd_type', +); + # This subtype is to support scalar -> arrayref coercion # without polluting the built-in types subtype '_MooseX_Getopt_CmdAliases' => as 'ArrayRef'; diff --git a/lib/MooseX/Getopt/Parser.pm b/lib/MooseX/Getopt/Parser.pm index 0c67e74..945d113 100644 --- a/lib/MooseX/Getopt/Parser.pm +++ b/lib/MooseX/Getopt/Parser.pm @@ -2,6 +2,6 @@ package MooseX::Getopt::Parser; use Moose::Role; -requires '_get_getopt_spec', 'getoptions'; +requires 'build_options'; 1; diff --git a/lib/MooseX/Getopt/Parser/Descriptive.pm b/lib/MooseX/Getopt/Parser/Descriptive.pm index bdcc26e..70631e1 100644 --- a/lib/MooseX/Getopt/Parser/Descriptive.pm +++ b/lib/MooseX/Getopt/Parser/Descriptive.pm @@ -7,7 +7,13 @@ with 'MooseX::Getopt::Parser'; use Getopt::Long::Descriptive; -sub getoptions { +use Do::Not::Load::This::Module; + +sub BUILD { + Moose->throw_error('Not yet implemented'); +}; + +sub get_options { my ($class, $opt_spec) = @_; return Getopt::Long::Descriptive::describe_options($class->_usage_format, @$opt_spec); } diff --git a/lib/MooseX/Getopt/Parser/Long.pm b/lib/MooseX/Getopt/Parser/Long.pm index e7fd7d3..a6a2800 100644 --- a/lib/MooseX/Getopt/Parser/Long.pm +++ b/lib/MooseX/Getopt/Parser/Long.pm @@ -5,31 +5,86 @@ use Moose; with 'MooseX::Getopt::Parser'; -sub getoptions { - my ($class, $opt_spec) = @_; +use Getopt::Long; +use MooseX::Getopt::OptionTypeMap; + +#use Smart::Comments; + +# Special configuration for parser +has 'config' => ( + is => 'rw', + isa => 'ArrayRef[Str]', + auto_deref => 1, + default => sub { [] }, +); + + +sub build_options { + my $self = shift; + my ($getopt, @attrs) = @_; + + Moose->throw_error('First argument is not a MooseX::Getopt::Session') + unless $getopt->isa('MooseX::Getopt::Session'); my %options; - my $getopt = Getopt::Long::Parser->new; - $getopt->getoptions(\%options, @$opt_spec); - return ( \%options, undef ); -} + my @opts; + + foreach my $attr (@attrs) { + my $name = $attr->name; + + my $is_cmd = $attr->does('MooseX::Getopt::Meta::Attribute::Trait'); + + my $opt_string = $is_cmd && $attr->has_cmd_flag + ? $attr->cmd_flag + : $name; + + if ($is_cmd && $attr->has_cmd_aliases && scalar @{ $attr->cmd_aliases }) { + $opt_string .= '|' . join '|', @{ $attr->cmd_aliases }; + }; + + if ($is_cmd && $attr->has_cmd_type || $attr->has_type_constraint) { + my $type = $is_cmd && $attr->has_cmd_type ? $attr->cmd_type : $attr->type_constraint; + if (MooseX::Getopt::OptionTypeMap->has_option_type($type)) { + $opt_string .= MooseX::Getopt::OptionTypeMap->get_option_type($type) + }; + }; + + $options{$name} = undef; + push @opts, $opt_string => \$options{$name}; + }; + + ### MooseX::Getopt::Parser::Long::build_options @opts : @opts + + GETOPT: { + my $parser = new Getopt::Long::Parser; + $parser->configure( $self->config ); + + local @ARGV = $getopt->argv; + ### MooseX::Getopt::Parser::Long::build_options @ARGV : @ARGV + + local $SIG{__WARN__} = sub { + return warn @_ if $_[0]=~/^\###/; # Smart::Comments + my $warning = $getopt->has_warning ? $getopt->warning : ''; + $warning .= $_[0]; + $getopt->warning( $warning ) + }; -sub _get_getopt_spec { - my ($class, %params) = @_; + my $status = $parser->getoptions( @opts ); + $getopt->status( $status ); - my ( @options, %name_to_init_arg, %options ); + my $extra_argv = \@ARGV; + $getopt->extra_argv( $extra_argv ); + }; - foreach my $opt ( @{ $params{options} } ) { - push @options, $opt->{opt_string}; + %options = map { $_ => $options{$_} } grep { defined $options{$_} } keys %options; + $getopt->options( \%options ); - my $identifier = $opt->{name}; - $identifier =~ s/\W/_/g; # Getopt::Long does this to all option names + die join '', $getopt->warning if $getopt->die_on_warning && $getopt->has_warning; - $name_to_init_arg{$identifier} = $opt->{init_arg}; - } + ### MooseX::Getopt::Parser::Long::build_options %options : %options + return \%options; +}; - return ( \@options, \%name_to_init_arg ); -} 1; diff --git a/lib/MooseX/Getopt/Session.pm b/lib/MooseX/Getopt/Session.pm new file mode 100644 index 0000000..c75c34e --- /dev/null +++ b/lib/MooseX/Getopt/Session.pm @@ -0,0 +1,103 @@ + +package MooseX::Getopt::Session; + +use Moose; + +use MooseX::Getopt::Parser::Long; +use maybe 'MooseX::Getopt::Parser::Descriptive'; + +#use Smart::Comments; + +# Pluggined MooseX::Getopt::Parser parser +has 'getopt_parser' => ( + is => 'rw', + does => 'MooseX::Getopt::Parser', + default => sub { + maybe::HAVE_MOOSEX_GETOPT_PARSER_DESCRIPTIVE + ? MooseX::Getopt::Parser::Descriptive->new + : MooseX::Getopt::Parser::Long->new + }, +); + +# Filter for classes which are searched for getopt trait +has 'classes_filter' => ( + is => 'rw', + isa => 'CodeRef', + default => sub { sub { 1 } }, +); + +# Original @ARGV values +has 'argv' => ( + is => 'rw', + isa => 'ArrayRef[Str]', + auto_deref => 1, + default => sub { [ @ARGV ] }, +); + +# Unrecognized @ARGV values +has 'extra_argv' => ( + is => 'rw', + isa => 'ArrayRef[Str]', + auto_deref => 1, + default => sub { [] }, +); + +# Hash with options parsed from argv +has 'options' => ( + is => 'rw', + isa => 'HashRef', + auto_deref => 1, + default => sub { {} }, +); + +# Status of parser +has 'status' => ( + is => 'rw', + isa => 'Bool', +); + +# Warnings collected by parser +has 'warning' => ( + is => 'rw', + isa => 'Str', + predicate => 'has_warning', +); + +# Die if warnings was occured +has 'die_on_warning' => ( + is => 'rw', + isa => 'Bool', + default => 1, +); + + +sub BUILD { + ### MooseX::Getopt::Session::BUILD : @_ + my ($self, $args) = @_; + + $self->build_options; +}; + + +sub build_options { + my ($self) = @_; + + my @attrs = map { $_->_compute_getopt_attrs } $self->_compute_getopt_classes; + ### MooseX::Getopt::Session::build_options @attrs -> name : map { $_->name } @attrs + + return $self->getopt_parser->build_options( $self, @attrs ); +} + + +sub _compute_getopt_classes { + my $self = shift; + + return grep { + $self->classes_filter->() + } grep { + $_->isa('Moose::Object') && $_->does('MooseX::Getopt') + } Class::MOP->get_all_metaclasses; +}; + + +1;