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

[gitmo/MooseX-Getopt.git] / lib / MooseX / Getopt / Parser / Descriptive.pm

diff --git a/lib/MooseX/Getopt/Parser/Descriptive.pm b/lib/MooseX/Getopt/Parser/Descriptive.pm
index bdcc26e..63e9744 100644 (file)
--- a/lib/MooseX/Getopt/Parser/Descriptive.pm
+++ b/lib/MooseX/Getopt/Parser/Descriptive.pm
@@ -6,46 +6,95 @@ use Moose;
 with 'MooseX::Getopt::Parser';
 
 use Getopt::Long::Descriptive;
+use MooseX::Getopt::OptionTypeMap;
 
-sub getoptions {
-    my ($class, $opt_spec) = @_;
-    return Getopt::Long::Descriptive::describe_options($class->_usage_format, @$opt_spec);
-}
+#use Smart::Comments;
 
-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;
+
+        my ($flag, @aliases) = $getopt->_get_cmd_flags_for_attr($attr);
+        my $type = $getopt->_get_cmd_type_for_attr($attr);
+
+        my $opt_string = join '|', $flag, @aliases;
+        $opt_string .= MooseX::Getopt::OptionTypeMap->get_option_type($type);
+
+        my $doc;
+        $doc = $attr->documentation if $attr->has_documentation;
+        $doc = ' ' unless $doc;
+
+        my $is_required = $attr->is_required && !$attr->has_default && !$attr->has_builder;
+
+        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 ) : () ),
+            }
         ];
+    };
+
+    ### MooseX::Getopt::Parser::Descriptive::build_options @opts : @opts
+
+    GETOPT: {
+        local @ARGV = $getopt->argv;
+        ### MooseX::Getopt::Parser::Descriptive::build_options @ARGV : @ARGV
+
+        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;