transform MooseX::Getopt::GLD into a MooseX::Parameterized Role

diff --git a/ChangeLog b/ChangeLog
index 569338f..14d6cda 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,10 @@
 Revision history for Perl extension MooseX-Getopt
 
+{{NEXT}}
+  * MooseX::Getopt::GLD
+    - change it to a MooseX::Role::Parameterized, so that it accepts
+      'getopt_conf' parameter (Damien Krotkine)
+
 0.35 Wed 09 Feb 2011
   * Fix missed change from Test::Exception to Test::Fatal
 

diff --git a/lib/MooseX/Getopt/GLD.pm b/lib/MooseX/Getopt/GLD.pm
index 5edb937..97298e0 100644 (file)
--- a/lib/MooseX/Getopt/GLD.pm
+++ b/lib/MooseX/Getopt/GLD.pm
@@ -1,70 +1,84 @@
 package MooseX::Getopt::GLD;
 # ABSTRACT: A Moose role for processing command line options with Getopt::Long::Descriptive
 
-use Moose::Role;
+use MooseX::Role::Parameterized;
 
 use Getopt::Long::Descriptive 0.081;
 
 with 'MooseX::Getopt::Basic';
 
-has usage => (
-    is => 'rw', isa => 'Getopt::Long::Descriptive::Usage',
-    traits => ['NoGetopt'],
+parameter getopt_conf => (
+    isa => 'ArrayRef[Str]',
+    default => sub { [] },
 );
 
-# captures the options: --help --usage --?
-has help_flag => (
-    is => 'ro', isa => 'Bool',
-    traits => ['Getopt'],
-    cmd_flag => 'help',
-    cmd_aliases => [ qw(usage ?) ],
-    documentation => 'Prints this usage information.',
-);
-
-around _getopt_spec => sub {
-    shift;
-    shift->_gld_spec(@_);
-};
-
-around _getopt_get_options => sub {
-    shift;
-    my ($class, $params, $opt_spec) = @_;
-    return Getopt::Long::Descriptive::describe_options($class->_usage_format(%$params), @$opt_spec);
-};
-
-sub _gld_spec {
-    my ( $class, %params ) = @_;
-
-    my ( @options, %name_to_init_arg );
-
-    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
-            {
-                ( ( $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})  : () ),
-            },
-        ];
-
-        my $identifier = lc($opt->{name});
-        $identifier =~ s/\W/_/g; # Getopt::Long does this to all option names
-
-        $name_to_init_arg{$identifier} = $opt->{init_arg};
+role {
+
+    my $p = shift;
+    my $getopt_conf = $p->getopt_conf;
+
+    has usage => (
+        is => 'rw', isa => 'Getopt::Long::Descriptive::Usage',
+        traits => ['NoGetopt'],
+    );
+
+    # captures the options: --help --usage --?
+    has help_flag => (
+        is => 'ro', isa => 'Bool',
+        traits => ['Getopt'],
+        cmd_flag => 'help',
+        cmd_aliases => [ qw(usage ?) ],
+        documentation => 'Prints this usage information.',
+    );
+
+    around _getopt_spec => sub {
+        shift;
+        shift->_gld_spec(@_);
+    };
+
+    around _getopt_get_options => sub {
+        shift;
+        my ($class, $params, $opt_spec) = @_;
+        # Check if a special args hash were already passed, or create a new one
+        my $args = ref($opt_spec->[-1]) eq 'HASH' ? pop @$opt_spec : {};
+        unshift @{$args->{getopt_conf}}, @$getopt_conf;
+        push @$opt_spec, $args;
+        return Getopt::Long::Descriptive::describe_options($class->_usage_format(%$params), @$opt_spec);
+    };
+
+    method _gld_spec => sub {
+        my ( $class, %params ) = @_;
+
+        my ( @options, %name_to_init_arg );
+
+        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
+                {
+                    ( ( $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})  : () ),
+                },
+            ];
+
+            my $identifier = lc($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 );
     }
+};
 
-    return ( \@options, \%name_to_init_arg );
-}
-
-no Moose::Role;
 
 1;
 

diff --git a/t/111_gld_pass_through.t b/t/111_gld_pass_through.t
new file mode 100644 (file)
index 0000000..1a02861
--- /dev/null
+++ b/t/111_gld_pass_through.t
@@ -0,0 +1,55 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 5;
+
+use Test::Requires {
+    'Getopt::Long::Descriptive' => 0.01, # skip all if not installed
+};
+
+use_ok('MooseX::Getopt::GLD');
+
+{
+    package Engine::Foo;
+    use Moose;
+
+    with 'MooseX::Getopt::GLD' => { getopt_conf => [ 'pass_through' ] };
+
+    has 'foo' => (
+        metaclass   => 'Getopt',
+        is          => 'ro',
+        isa         => 'Int',
+    );
+}
+
+{
+    package Engine::Bar;
+    use Moose;
+
+    with 'MooseX::Getopt::GLD' => { getopt_conf => [ 'pass_through' ] };;
+
+    has 'bar' => (
+        metaclass   => 'Getopt',
+        is          => 'ro',
+        isa         => 'Int',
+    );
+}
+
+local @ARGV = ('--foo=10', '--bar=42');
+
+{
+    my $foo = Engine::Foo->new_with_options();
+    isa_ok($foo, 'Engine::Foo');
+    is($foo->foo, 10, '... got the right value (10)');
+}
+
+{
+    my $bar = Engine::Bar->new_with_options();
+    isa_ok($bar, 'Engine::Bar');
+    is($bar->bar, 42, '... got the right value (42)');
+}
+
+
+