From: Piotr Roszatycki <piotr.roszatycki@gmail.com>
Date: Wed, 12 Nov 2008 08:16:58 +0000 (+0000)
Subject: * MooseX::Getopt::Parser::Descriptive reimplemented.
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=dd012666739d0d4f7f629b22b047a4c8117764a9;p=gitmo%2FMooseX-Getopt.git

* MooseX::Getopt::Parser::Descriptive reimplemented.
---

dd012666739d0d4f7f629b22b047a4c8117764a9
diff --cc lib/MooseX/Getopt/Parser/Descriptive.pm
index 70631e1,bdcc26e..63e9744
--- a/lib/MooseX/Getopt/Parser/Descriptive.pm
+++ b/lib/MooseX/Getopt/Parser/Descriptive.pm
@@@ -6,52 -6,46 +6,95 @@@ use Moose
  with 'MooseX::Getopt::Parser';
  
  use Getopt::Long::Descriptive;
++use MooseX::Getopt::OptionTypeMap;
  
- use Do::Not::Load::This::Module;
 -sub getoptions {
 -    my ($class, $opt_spec) = @_;
 -    return Getopt::Long::Descriptive::describe_options($class->_usage_format, @$opt_spec);
 -}
++#use Smart::Comments;
  
- sub BUILD {
-     Moose->throw_error('Not yet implemented'); 
- };
 -sub _get_getopt_spec {
 -    my ($class, %params) = @_;
++# Special configuration for parser
++has 'config' => (
++    is => 'rw',
++    isa => 'ArrayRef[Str]',
++    auto_deref => 1,
++    default => sub { [] },
++);
+ 
 -    my (@options, %name_to_init_arg );
++# Format for usage description
++has 'format' => (
++    is => 'rw',
++    isa => 'Str',
++    default => 'usage: %c %o',
++);
+ 
 -    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
++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, $usage);
++    my @opts;
++
++    foreach my $attr (@attrs) {
++        my $name = $attr->name;
 +
- sub get_options {
-     my ($class, $opt_spec) = @_;
-     return Getopt::Long::Descriptive::describe_options($class->_usage_format, @$opt_spec);
- }
++        my ($flag, @aliases) = $getopt->_get_cmd_flags_for_attr($attr);
++        my $type = $getopt->_get_cmd_type_for_attr($attr);
 +
- sub _get_getopt_spec {
-     my ($class, %params) = @_;
++        my $opt_string = join '|', $flag, @aliases;
++        $opt_string .= MooseX::Getopt::OptionTypeMap->get_option_type($type);
 +
-     my (@options, %name_to_init_arg );
++        my $doc;
++        $doc = $attr->documentation if $attr->has_documentation;
++        $doc = ' ' unless $doc;
 +
-     my $constructor_params = $params{params};
++        my $is_required = $attr->is_required && !$attr->has_default && !$attr->has_builder;
 +
-     foreach my $opt ( @{ $params{options} } ) {
-         push @options, [
-             $opt->{opt_string},
-             $opt->{doc} || ' ', # FIXME new GLD shouldn't need this hack
++        push @opts, [
++            $opt_string => $doc,
              {
--                ( ( $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})  : () ),
--            },
++                ( $is_required ? ( required => $attr->is_required ) : () ),
++            }
          ];
++    };
 +
-         my $identifier = $opt->{name};
-         $identifier =~ s/\W/_/g; # Getopt::Long does this to all option names
++    ### MooseX::Getopt::Parser::Descriptive::build_options @opts : @opts
 +
-         $name_to_init_arg{$identifier} = $opt->{init_arg};
-     }
++    GETOPT: {
++        local @ARGV = $getopt->argv;
++        ### MooseX::Getopt::Parser::Descriptive::build_options @ARGV : @ARGV
 +
-     return ( \@options, \%name_to_init_arg );
- }
++        local $SIG{__WARN__} = sub {
++            return warn @_ if $_[0]=~/^\###/;   # Smart::Comments
++            $getopt->strcat_warning( $_[0] )
++        };
++
++        eval {
++            ($options, $usage) = Getopt::Long::Descriptive::describe_options(
++                $self->format, @opts, { getopt_conf => [ $self->config ] }
++            );
++        };
++        my $e = $@;
++        $getopt->strcat_warning( $e ) if $e;
++        $getopt->status( ! $e );
++
++        my $extra_argv = \@ARGV;
++        $getopt->extra_argv( $extra_argv );
++    };
++
++    #%options = map { $_ => $options{$_} } grep { defined $options{$_} } keys %options;
++    $getopt->options( defined $options ? $options : {} );
+ 
 -        my $identifier = $opt->{name};
 -        $identifier =~ s/\W/_/g; # Getopt::Long does this to all option names
++    ### MooseX::Getopt::Parser::Descriptive::build_options $options : $options
++    ### MooseX::Getopt::Parser::Descriptive::build_options $usage : $usage
++    ### MooseX::Getopt::Parser::Descriptive::build_options $getopt->status : $getopt->status
+ 
 -        $name_to_init_arg{$identifier} = $opt->{init_arg};
 -    }
++    die join '', $getopt->warning
++        if $getopt->die_on_warning && ($getopt->has_warning || !$getopt->status);
+ 
 -    return ( \@options, \%name_to_init_arg );
 -}
++    return $options;
++};
  
--sub _usage_format {
--    return "usage: %c %o";
--}
  
  1;
diff --cc lib/MooseX/Getopt/Session.pm
index 57b5220,0000000..0b10744
mode 100644,000000..100644
--- a/lib/MooseX/Getopt/Session.pm
+++ b/lib/MooseX/Getopt/Session.pm
@@@ -1,134 -1,0 +1,141 @@@
 +
 +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;
 +};
 +
 +
 +sub _get_cmd_flags_for_attr {
 +    my ($self, $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 _get_cmd_type_for_attr {
 +    my ($self, $attr) = @_;
 +
 +    my $type;
 +    
 +    $type = $attr->type_constraint if $attr->has_type_constraint;
 +
 +    if ($attr->does('MooseX::Getopt::Meta::Attribute::Trait')) {
 +        $type = $attr->cmd_type if $attr->has_cmd_type;
 +    };
 +
 +    return $type;
 +};
 +
 +
++sub strcat_warning {
++    my ($self, $string) = @_;
++
++    return $self->warning( ($self->has_warning ? $self->warning : '') . $string );
++};
++
++
 +1;