* MooseX::Getopt::Parser::Descriptive: Unmagle field names in options hashref.
* t/00[1234]*.t: Test both of parsers.
- Use Moose's throw_error() method. (dexter)
* MooseX::Getopt
+ * MooseX::Getopt::Session
+ - MooseX::Getopt can start new Getopt session or get it as parameter
+ (dexter)
+
* MooseX::Getopt::Parser
* MooseX::Getopt::Parser::Long
* MooseX::Getopt::Parser::Descriptive
- - Handling with Getopt parser implemented as strategy pattern.
+ - Getopt parser is pluggined.
(dexter)
+ * TODO:
- - MooseX::Getopt::Parser::Descriptive is not implemeted yet.
+ - MooseX::ConfigFromFile should be restored?
+ - POD.
+ - New test units.
+
0.15 Sat. July 26 2008
* MooseX::Getopt::OptionTypeMap
- Accept type constraint objects in the type mapping, not just names
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;
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 );
- die join '', $getopt->warning if $getopt->die_on_warning && $getopt->has_warning;
- 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;
--- /dev/null
+
+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' => (
++has '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 );
++ return $self->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;
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');
++ }
++
++ }
}
use strict;
use warnings;
--use Test::More tests => 6;
++use Test::More tests => 21;
BEGIN {
use_ok('MooseX::Getopt');
package App;
use Moose;
use Moose::Util::TypeConstraints;
--
++
use Scalar::Util 'looks_like_number';
--
++
with 'MooseX::Getopt';
subtype 'ArrayOfInts'
=> as 'ArrayRef'
=> where { scalar (grep { looks_like_number($_) } @$_) };
--
++
MooseX::Getopt::OptionTypeMap->add_option_type_to_map(
'ArrayOfInts' => '=i@'
);
--
++
has 'nums' => (
is => 'ro',
isa => 'ArrayOfInts',
default => sub { [0] }
-- );
--
++ );
++
}
--{
-- 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", 10 if $@;
++ }
-- my $app = App->new_with_options;
-- isa_ok($app, 'App');
--
-- is_deeply($app->nums, [0], '... nums is [0] as expected');
--}
++ {
++ local @ARGV = ();
--{
-- local @ARGV = ('--nums', 3, '--nums', 5);
++ my $parser = $parser_name->new;
++ isa_ok($parser, $parser_name);
-- my $app = App->new_with_options;
-- isa_ok($app, 'App');
--
-- is_deeply($app->nums, [3, 5], '... nums is [3, 5] as expected');
--}
++ 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');
--# Make sure it really used our =i@, instead of falling back
--# to =s@ via the type system, and test that exceptions work
--# while we're at it.
--eval {
-- local @ARGV = ('--nums', 3, '--nums', 'foo');
++ is_deeply($app->nums, [0], '... nums is [0] as expected');
++ }
-- my $app = App->new_with_options;
--};
--like($@, qr/Value "foo" invalid/, 'Numeric constraint enforced');
++ {
++ local @ARGV = ('--nums', 3, '--nums', 5);
++
++ 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->nums, [3, 5], '... nums is [3, 5] as expected');
++ }
++
++ # Make sure it really used our =i@, instead of falling back
++ # to =s@ via the type system, and test that exceptions work
++ # while we're at it.
++ eval {
++ local @ARGV = ('--nums', 3, '--nums', '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 );
++ };
++ like($@, qr/Value "foo" invalid/, 'Numeric constraint enforced');
++
++ }
++}
use strict;
use warnings;
--use Test::More tests => 5;
++use Test::More tests => 17;
BEGIN {
use_ok('MooseX::Getopt');
package App;
use Moose;
use Moose::Util::TypeConstraints;
--
++
use Scalar::Util 'looks_like_number';
--
++
with 'MooseX::Getopt';
subtype 'ArrayOfInts'
=> as 'ArrayRef'
=> where { scalar (grep { looks_like_number($_) } @$_) };
--
++
has 'nums' => (
is => 'ro',
isa => 'ArrayOfInts',
default => sub { [0] }
-- );
--
++ );
++
}
--{
-- 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", 8 if $@;
++ }
-- my $app = App->new_with_options;
-- isa_ok($app, 'App');
--
-- is_deeply($app->nums, [0], '... nums is [0] as expected');
--}
++ {
++ local @ARGV = ();
--{
-- local @ARGV = ('--nums', 3, '--nums', 5);
++ my $parser = $parser_name->new;
++ isa_ok($parser, $parser_name);
-- my $app = App->new_with_options;
-- isa_ok($app, 'App');
--
-- is_deeply($app->nums, [3, 5], '... nums is [3, 5] as expected');
--}
++ 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->nums, [0], '... nums is [0] as expected');
++ }
++
++ {
++ local @ARGV = ('--nums', 3, '--nums', 5);
++
++ 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->nums, [3, 5], '... nums is [3, 5] as expected');
++ }
++
++ }
++}
use strict;
use warnings;
--use Test::More tests => 9;
++use Test::More tests => 23;
use Test::Exception;
BEGIN {
}
--{
-- 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", 11 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' );
-- is($app->private_stuff, 713, '... private stuff is 713 as expected');
--}
++ my $parser = $parser_name->new;
++ isa_ok($parser, $parser_name);
--{
-- local @ARGV = (qw/--private_stuff 317/);
++ 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 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' );
++ is($app->private_stuff, 713, '... private stuff is 713 as expected');
++ }
++
++ {
++ local @ARGV = (qw/--private_stuff 317/);
++
++ throws_ok {
++
++ my $parser = $parser_name->new;
++ isa_ok($parser, $parser_name);
++
++ my $getopt = MooseX::Getopt::Session->new( parser => $parser );
++ isa_ok($getopt, 'MooseX::Getopt::Session');
++
++ App->new_with_options( getopt => $getopt )
++
++ } qr/Unknown option: private_stuff/;
++ }
-- throws_ok { App->new_with_options } qr/Unknown option: private_stuff/;
++ }
}