* MooseX::Getopt::Session: Drop die_on_warning attribute.

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

diff --git a/lib/MooseX/Getopt/Parser/Long.pm b/lib/MooseX/Getopt/Parser/Long.pm
index e7fd7d3..12f6565 100644 (file)
--- a/lib/MooseX/Getopt/Parser/Long.pm
+++ b/lib/MooseX/Getopt/Parser/Long.pm
@@ -5,31 +5,74 @@ 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 @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);
+
+        $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
 
-    my $getopt = Getopt::Long::Parser->new;
-    $getopt->getoptions(\%options, @$opt_spec);
-    return ( \%options, undef );
-}
+        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->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;