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;
++ my $options = {};
++ my $usage;
++ my (@opts, %cmd_flags_to_names);
+
+ 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);
+
++ $cmd_flags_to_names{$flag} = $name;
++
+ 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 );
+ };
+
++ # Convert cmd_flags back to names in options hashref
++ $options = {
++ map {
++ $cmd_flags_to_names{$_} => $options->{$_}
++ } keys %$options,
++ };
++
+ #%options = map { $_ => $options{$_} } grep { defined $options{$_} } keys %options;
- $getopt->options( defined $options ? $options : {} );
++ $getopt->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
- die join '', $getopt->warning
- if $getopt->die_on_warning && ($getopt->has_warning || !$getopt->status);
- $name_to_init_arg{$identifier} = $opt->{init_arg};
- }
++ die join '', $getopt->warning if ($getopt->has_warning || !$getopt->status);
- return ( \@options, \%name_to_init_arg );
-}
+ return $options;
+};
-sub _usage_format {
- return "usage: %c %o";
-}
1;
use strict;
use warnings;
--use Test::More tests => 69;
++use Test::More tests => 173;
BEGIN {
use_ok('MooseX::Getopt');
{
package App;
use Moose;
--
++
with 'MooseX::Getopt';
has 'data' => (
-- metaclass => 'MooseX::Getopt::Meta::Attribute',
++ metaclass => 'MooseX::Getopt::Meta::Attribute',
is => 'ro',
isa => 'Str',
default => 'file.dat',
);
has 'cow' => (
-- metaclass => 'Getopt',
++ metaclass => 'Getopt',
is => 'ro',
isa => 'Str',
default => 'moo',
);
has 'horse' => (
-- metaclass => 'MooseX::Getopt::Meta::Attribute',
++ metaclass => 'MooseX::Getopt::Meta::Attribute',
is => 'ro',
isa => 'Str',
default => 'bray',
has 'verbose' => (
is => 'ro',
-- isa => 'Bool',
++ isa => 'Bool',
);
--
++
has 'libs' => (
is => 'ro',
isa => 'ArrayRef',
default => sub { [] },
-- );
--
++ );
++
has 'details' => (
is => 'ro',
isa => 'HashRef',
);
has '_private_stuff_cmdline' => (
-- metaclass => 'MooseX::Getopt::Meta::Attribute',
++ metaclass => 'MooseX::Getopt::Meta::Attribute',
is => 'ro',
isa => 'Int',
default => 832,
cmd_flag => 'p',
);
--
++
}
foreach my $attr_name (qw(data cow horse _private_stuff_cmdline)) {
isa_ok($attr, 'Moose::Meta::Attribute');
isa_ok($attr, 'MooseX::Getopt::Meta::Attribute');
can_ok($attr, 'cmd_flag');
-- can_ok($attr, 'cmd_aliases');
++ can_ok($attr, 'cmd_aliases');
}
--{
-- local @ARGV = ();
++foreach my $parser_name (qw(MooseX::Getopt::Parser::Long MooseX::Getopt::Parser::Descriptive)) {
++ SKIP: {
++ if ($parser_name eq 'MooseX::Getopt::Parser::Descriptive') {
++ eval { require Getopt::Long::Descriptive };
++ skip "Getopt::Long::Descriptive not installed", 78 if $@;
++ }
-- my $app = App->new_with_options;
-- isa_ok($app, 'App');
++ {
++ local @ARGV = ();
-- ok(!$app->verbose, '... verbosity is off as expected');
-- is($app->length, 24, '... length is 24 as expected');
-- is($app->data, 'file.dat', '... data is file.dat as expected');
-- is_deeply($app->libs, [], '... libs is [] as expected');
-- is_deeply($app->details, {}, '... details is {} as expected');
--}
++ my $parser = $parser_name->new;
++ isa_ok($parser, $parser_name);
--{
-- local @ARGV = ('--verbose', '--length', 50);
++ my $getopt = MooseX::Getopt::Session->new( parser => $parser );
++ isa_ok($getopt, 'MooseX::Getopt::Session');
-- my $app = App->new_with_options;
-- isa_ok($app, 'App');
++ my $app = App->new_with_options( getopt => $getopt );
++ isa_ok($app, 'App');
-- ok($app->verbose, '... verbosity is turned on as expected');
-- is($app->length, 50, '... length is 50 as expected');
-- is($app->data, 'file.dat', '... data is file.dat as expected');
-- is_deeply($app->libs, [], '... libs is [] as expected');
-- is_deeply($app->details, {}, '... details is {} as expected');
--}
++ ok(!$app->verbose, '... verbosity is off as expected');
++ is($app->length, 24, '... length is 24 as expected');
++ is($app->data, 'file.dat', '... data is file.dat as expected');
++ is_deeply($app->libs, [], '... libs is [] as expected');
++ is_deeply($app->details, {}, '... details is {} as expected');
++ }
--{
-- local @ARGV = ('--verbose', '-f', 'foo.txt');
++ {
++ local @ARGV = ('--verbose', '--length', 50);
-- my $app = App->new_with_options;
-- isa_ok($app, 'App');
++ my $parser = $parser_name->new;
++ isa_ok($parser, $parser_name);
-- ok($app->verbose, '... verbosity is turned on as expected');
-- is($app->length, 24, '... length is 24 as expected');
-- is($app->data, 'foo.txt', '... data is foo.txt as expected');
-- is_deeply($app->libs, [], '... libs is [] as expected');
-- is_deeply($app->details, {}, '... details is {} as expected');
--}
++ my $getopt = MooseX::Getopt::Session->new( parser => $parser );
++ isa_ok($getopt, 'MooseX::Getopt::Session');
--{
-- local @ARGV = ('--verbose', '--libs', 'libs/', '--libs', 'includes/lib');
--
-- my $app = App->new_with_options;
-- isa_ok($app, 'App');
--
-- ok($app->verbose, '... verbosity is turned on as expected');
-- is($app->length, 24, '... length is 24 as expected');
-- is($app->data, 'file.dat', '... data is foo.txt as expected');
-- is_deeply($app->libs,
-- ['libs/', 'includes/lib'],
-- '... libs is [libs/, includes/lib] as expected');
-- is_deeply($app->details, {}, '... details is {} as expected');
--}
++ my $app = App->new_with_options( getopt => $getopt );
++ isa_ok($app, 'App');
--{
-- local @ARGV = ('--details', 'os=mac', '--details', 'name=foo');
--
-- my $app = App->new_with_options;
-- isa_ok($app, 'App');
--
-- ok(!$app->verbose, '... verbosity is turned on as expected');
-- is($app->length, 24, '... length is 24 as expected');
-- is($app->data, 'file.dat', '... data is foo.txt as expected');
-- is_deeply($app->libs, [], '... libs is [] as expected');
-- is_deeply($app->details,
-- { os => 'mac', name => 'foo' },
-- '... details is { os => mac, name => foo } as expected');
--}
++ ok($app->verbose, '... verbosity is turned on as expected');
++ is($app->length, 50, '... length is 50 as expected');
++ is($app->data, 'file.dat', '... data is file.dat as expected');
++ is_deeply($app->libs, [], '... libs is [] as expected');
++ is_deeply($app->details, {}, '... details is {} as expected');
++ }
--{
-- # Test negation on booleans too ...
-- local @ARGV = ('--noverbose');
++ {
++ local @ARGV = ('--verbose', '-f', 'foo.txt');
-- my $app = App->new_with_options;
-- isa_ok($app, 'App');
++ my $parser = $parser_name->new;
++ isa_ok($parser, $parser_name);
-- ok(!$app->verbose, '... verbosity is turned off as expected');
-- is($app->length, 24, '... length is 24 as expected');
-- is($app->data, 'file.dat', '... file is file.dat as expected');
-- is_deeply($app->libs, [], '... libs is [] as expected');
-- is_deeply($app->details, {}, '... details is {} as expected');
--}
++ my $getopt = MooseX::Getopt::Session->new( parser => $parser );
++ isa_ok($getopt, 'MooseX::Getopt::Session');
--# Test cmd_alias without cmd_flag
--{
-- local @ARGV = ('--cow', '42');
-- my $app = App->new_with_options;
-- isa_ok($app, 'App');
-- is($app->cow, 42, 'cmd_alias, but not using it');
--}
--{
-- local @ARGV = ('--moocow', '88');
-- my $app = App->new_with_options;
-- isa_ok($app, 'App');
-- is($app->cow, 88, 'cmd_alias, using long one');
--}
--{
-- local @ARGV = ('-c', '99');
-- my $app = App->new_with_options;
-- isa_ok($app, 'App');
-- is($app->cow, 99, 'cmd_alias, using short one');
--}
++ my $app = App->new_with_options( getopt => $getopt );
++ isa_ok($app, 'App');
--# Test cmd_alias + cmd_flag
--{
-- local @ARGV = ('--horsey', '123');
-- my $app = App->new_with_options;
-- isa_ok($app, 'App');
-- is($app->horse, 123, 'cmd_alias+cmd_flag, using flag');
--}
--{
-- local @ARGV = ('-x', '321');
-- my $app = App->new_with_options;
-- isa_ok($app, 'App');
-- is($app->horse, 321, 'cmd_alias+cmd_flag, using alias');
--}
++ ok($app->verbose, '... verbosity is turned on as expected');
++ is($app->length, 24, '... length is 24 as expected');
++ is($app->data, 'foo.txt', '... data is foo.txt as expected');
--# Test _foo + cmd_flag
--{
-- local @ARGV = ('-p', '666');
-- my $app = App->new_with_options;
-- isa_ok($app, 'App');
-- is($app->_private_stuff_cmdline, 666, '_foo + cmd_flag');
--}
++ is_deeply($app->libs, [], '... libs is [] as expected');
++ is_deeply($app->details, {}, '... details is {} as expected');
++ }
--# Test ARGV support
--{
-- my @args = ('-p', 12345, '-c', 99, '-');
-- local @ARGV = @args;
-- my $app = App->new_with_options;
-- isa_ok($app, 'App');
-- is_deeply($app->ARGV, \@args, 'ARGV accessor');
-- is_deeply(\@ARGV, \@args, '@ARGV unmangled');
-- is_deeply($app->extra_argv, ['-'], 'extra_argv accessor');
++ {
++ local @ARGV = ('--verbose', '--libs', 'libs/', '--libs', 'includes/lib');
++
++ my $parser = $parser_name->new;
++ isa_ok($parser, $parser_name);
++
++ my $getopt = MooseX::Getopt::Session->new( parser => $parser );
++ isa_ok($getopt, 'MooseX::Getopt::Session');
++
++ my $app = App->new_with_options( getopt => $getopt );
++ isa_ok($app, 'App');
++
++ ok($app->verbose, '... verbosity is turned on as expected');
++ is($app->length, 24, '... length is 24 as expected');
++ is($app->data, 'file.dat', '... data is foo.txt as expected');
++ is_deeply($app->libs,
++ ['libs/', 'includes/lib'],
++ '... libs is [libs/, includes/lib] as expected');
++ is_deeply($app->details, {}, '... details is {} as expected');
++ }
++
++ {
++ local @ARGV = ('--details', 'os=mac', '--details', 'name=foo');
++
++ my $parser = $parser_name->new;
++ isa_ok($parser, $parser_name);
++
++ my $getopt = MooseX::Getopt::Session->new( parser => $parser );
++ isa_ok($getopt, 'MooseX::Getopt::Session');
++
++ my $app = App->new_with_options( getopt => $getopt );
++ isa_ok($app, 'App');
++
++ ok(!$app->verbose, '... verbosity is turned on as expected');
++ is($app->length, 24, '... length is 24 as expected');
++ is($app->data, 'file.dat', '... data is foo.txt as expected');
++ is_deeply($app->libs, [], '... libs is [] as expected');
++ is_deeply($app->details,
++ { os => 'mac', name => 'foo' },
++ '... details is { os => mac, name => foo } as expected');
++ }
++
++ {
++ # Test negation on booleans too ...
++ local @ARGV = ('--noverbose');
++
++ my $parser = $parser_name->new;
++ isa_ok($parser, $parser_name);
++
++ my $getopt = MooseX::Getopt::Session->new( parser => $parser );
++ isa_ok($getopt, 'MooseX::Getopt::Session');
++
++ my $app = App->new_with_options( getopt => $getopt );
++ isa_ok($app, 'App');
++
++ ok(!$app->verbose, '... verbosity is turned off as expected');
++ is($app->length, 24, '... length is 24 as expected');
++ is($app->data, 'file.dat', '... file is file.dat as expected');
++ is_deeply($app->libs, [], '... libs is [] as expected');
++ is_deeply($app->details, {}, '... details is {} as expected');
++ }
++
++ # Test cmd_alias without cmd_flag
++ {
++ local @ARGV = ('--cow', '42');
++
++ my $parser = $parser_name->new;
++ isa_ok($parser, $parser_name);
++
++ my $getopt = MooseX::Getopt::Session->new( parser => $parser );
++ isa_ok($getopt, 'MooseX::Getopt::Session');
++
++ my $app = App->new_with_options( getopt => $getopt );
++ isa_ok($app, 'App');
++ is($app->cow, 42, 'cmd_alias, but not using it');
++ }
++ {
++ local @ARGV = ('--moocow', '88');
++
++ my $parser = $parser_name->new;
++ isa_ok($parser, $parser_name);
++
++ my $getopt = MooseX::Getopt::Session->new( parser => $parser );
++ isa_ok($getopt, 'MooseX::Getopt::Session');
++
++ my $app = App->new_with_options( getopt => $getopt );
++ isa_ok($app, 'App');
++ is($app->cow, 88, 'cmd_alias, using long one');
++ }
++ {
++ local @ARGV = ('-c', '99');
++
++ my $parser = $parser_name->new;
++ isa_ok($parser, $parser_name);
++
++ my $getopt = MooseX::Getopt::Session->new( parser => $parser );
++ isa_ok($getopt, 'MooseX::Getopt::Session');
++
++ my $app = App->new_with_options( getopt => $getopt );
++ isa_ok($app, 'App');
++ is($app->cow, 99, 'cmd_alias, using short one');
++ }
++
++ # Test cmd_alias + cmd_flag
++ {
++ local @ARGV = ('--horsey', '123');
++
++ my $parser = $parser_name->new;
++ isa_ok($parser, $parser_name);
++
++ my $getopt = MooseX::Getopt::Session->new( parser => $parser );
++ isa_ok($getopt, 'MooseX::Getopt::Session');
++
++ my $app = App->new_with_options( getopt => $getopt );
++ isa_ok($app, 'App');
++ is($app->horse, 123, 'cmd_alias+cmd_flag, using flag');
++ }
++ {
++ local @ARGV = ('-x', '321');
++
++ my $parser = $parser_name->new;
++ isa_ok($parser, $parser_name);
++
++ my $getopt = MooseX::Getopt::Session->new( parser => $parser );
++ isa_ok($getopt, 'MooseX::Getopt::Session');
++
++ my $app = App->new_with_options( getopt => $getopt );
++ isa_ok($app, 'App');
++ is($app->horse, 321, 'cmd_alias+cmd_flag, using alias');
++ }
++
++ # Test _foo + cmd_flag
++ {
++ local @ARGV = ('-p', '666');
++
++ my $parser = $parser_name->new;
++ isa_ok($parser, $parser_name);
++
++ my $getopt = MooseX::Getopt::Session->new( parser => $parser );
++ isa_ok($getopt, 'MooseX::Getopt::Session');
++
++ my $app = App->new_with_options( getopt => $getopt );
++ isa_ok($app, 'App');
++ is($app->_private_stuff_cmdline, 666, '_foo + cmd_flag');
++ }
++
++ # Test ARGV support
++ {
++ my @args = ('-p', 12345, '-c', 99, '-');
++
++ local @ARGV = @args;
++
++ my $parser = $parser_name->new;
++ isa_ok($parser, $parser_name);
++
++ my $getopt = MooseX::Getopt::Session->new( parser => $parser );
++ isa_ok($getopt, 'MooseX::Getopt::Session');
++
++ my $app = App->new_with_options( getopt => $getopt );
++ isa_ok($app, 'App');
++ is_deeply($app->ARGV, \@args, 'ARGV accessor');
++ is_deeply(\@ARGV, \@args, '@ARGV unmangled');
++ is_deeply($app->extra_argv, ['-'], 'extra_argv accessor');
++ }
++
++ }
}