* MooseX::Getopt::Parser::Default: Factory which returns default MooseX::Getopt::Parser.
* MooseX::Getopt::OptionTypeMap: Call Moose->throw_error for errors.
* t/*.t: Test units for MooseX::Getopt::Parser::Default.
* All code reformated.
0.150001 ???
* MooseX::Getopt
+ * MooseX::Getopt::OptionTypeMap
- Use Moose's throw_error() method. (dexter)
* MooseX::Getopt
(dexter)
* MooseX::Getopt::Parser
+ * MooseX::Getopt::Parser::Default
* MooseX::Getopt::Parser::Long
* MooseX::Getopt::Parser::Descriptive
- Getopt parser is pluggined.
* TODO:
- MooseX::ConfigFromFile should be restored?
- - POD.
- - New test units.
0.15 Sat. July 26 2008
* MooseX::Getopt::OptionTypeMap
lib/MooseX/Getopt/Meta/Attribute/Trait/NoGetopt.pm
lib/MooseX/Getopt/OptionTypeMap.pm
lib/MooseX/Getopt/Parser.pm
+lib/MooseX/Getopt/Parser/Default.pm
lib/MooseX/Getopt/Parser/Descriptive.pm
lib/MooseX/Getopt/Parser/Long.pm
lib/MooseX/Getopt/Session.pm
use constant _default_getopt_session => 'MooseX::Getopt::Session';
-has ARGV => (
- is => 'rw',
- isa => 'ArrayRef',
- metaclass => 'NoGetopt',
-);
-
-has extra_argv => (
- is => 'rw',
- isa => 'ArrayRef',
- metaclass => 'NoGetopt',
-);
-
has getopt => (
is => 'rw',
isa => 'MooseX::Getopt::Session',
metaclass => 'NoGetopt',
+ handles => [ 'ARGV', 'extra_argv' ],
);
my $getopt = defined $params{getopt}
? $params{getopt}
: $class->_default_getopt_session->new(
- classes_filter => sub { $_ eq $class },
- params => \%params,
- );
-
- my %options = $getopt->options;
+ classes_filter => sub { $_ eq $class },
+ params => \%params,
+ );
$class->new(
- ARGV => [ $getopt->argv ], # backward compatibility
- extra_argv => [ $getopt->extra_argv ], # backward compatibility
getopt => $getopt,
%{ $getopt->params }, # params from session object
%params, # explicit params to ->new
- %options, # params from CLI
+ %{ $getopt->options }, # params from CLI
);
};
like a normal C<ArrayRef> type for Getopt purposes (that is,
C<=s@>).
+=head2 Session
+
+L<MooseX::Getopt> can handle more than one class which contain
+attributes filled from CLI. In this case, you need to use explicite
+L<MooseX::Getopt::Session> object and then the Getopt attributes will be
+searched in any class which does L<MooseX::Getopt>.
+
+ package My::App;
+ use Moose;
+ with 'MooseX::Getopt';
+ has 'send' => (is => 'rw', predicate => 'has_send');
+
+ package My::App::Send;
+ use Moose;
+ with 'MooseX::Getopt';
+ has 'to' => (is => 'rw', isa => 'Str', default => 'localhost');
+ sub send { my $self = shift; warn "Sending mail to ", $self->to; }
+
+ # ... rest of the class here
+
+ ## in your script
+ #!/usr/bin/perl
+
+ my $getopt = MooseX::Getopt::Session->new;
+
+ my $app = My::App->new_with_options( getopt => $getopt );
+ if ($app->has_send) {
+ # Use the same command line
+ my $sender = My::App::Send->new_with_options( getopt => $getopt );
+ $sender->send;
+ }
+ # ... rest of the script here
+
+ ## on the command line
+ % perl my_app_script.pl --send --to server.example.net
+
=head1 METHODS
=over 4
=item B<ARGV>
-This accessor contains a reference to a copy of the C<@ARGV> array
-as it originally existed at the time of C<new_with_options>.
+This accessor contains a reference to a copy of the C<@ARGV> array as it
+originally existed at the time of C<new_with_options>.
+
+The C<ARGV> is delegated from L<MooseX::Getopt::Session> object.
=item B<extra_argv>
L<Getopt::Long> did not parse. Note that the real C<@ARGV> is left
un-mangled.
+The C<extra_argv> is delegated from L<MooseX::Getopt::Session> object.
+
+=item B<getopt>
+
+This accessor contains a L<MooseX::Getopt::Session> object. This object can
+be shared between more than one class which does L<MooseX::Getopt>. The new
+object is created by default.
+
=item B<meta>
This returns the role meta object.
=back
+=head1 SEE ALSO
+
+=over 4
+
+=item L<MooseX::Getopt::Strict>
+
+=item L<MooseX::Getopt::Session>
+
+=item L<MooseX::Getopt::Parser>
+
+=back
+
=head1 BUGS
All complex software has bugs lurking in it, and this module is no
Ryan D Johnson, E<lt>ryan@innerfence.comE<gt>
+Piotr Roszatycki, E<lt>dexter@cpan.orgE<gt>
+
=head1 COPYRIGHT AND LICENSE
Copyright 2007-2008 by Infinity Interactive, Inc.
'Int' => '=i',
'Num' => '=f',
'ArrayRef' => '=s@',
- 'HashRef' => '=s%',
+ 'HashRef' => '=s%',
);
sub has_option_type {
return 1 if exists $option_type_map{blessed($type_or_name) ? $type_or_name->name : $type_or_name};
my $current = blessed($type_or_name) ? $type_or_name : find_type_constraint($type_or_name);
-
+
(defined $current)
- || confess "Could not find the type constraint for '$type_or_name'";
-
+ || Moose->throw_error("Could not find the type constraint for '$type_or_name'");
+
while (my $parent = $current->parent) {
return 1 if exists $option_type_map{$parent->name};
$current = $parent;
return $option_type_map{$name} if exists $option_type_map{$name};
my $current = ref $type_or_name ? $type_or_name : find_type_constraint($type_or_name);
-
+
(defined $current)
- || confess "Could not find the type constraint for '$type_or_name'";
+ || Moose->throw_error("Could not find the type constraint for '$type_or_name'");
while ( $current = $current->parent ) {
return $option_type_map{$current->name}
sub add_option_type_to_map {
my (undef, $type_name, $option_string) = @_;
(defined $type_name && defined $option_string)
- || confess "You must supply both a type name and an option string";
+ || Moose->throw_error("You must supply both a type name and an option string");
if ( blessed($type_name) ) {
$type_name = $type_name->name;
} else {
(find_type_constraint($type_name))
- || confess "The type constraint '$type_name' does not exist";
+ || Moose->throw_error("The type constraint '$type_name' does not exist");
}
$option_type_map{$type_name} = $option_string;
=head1 BUGS
-All complex software has bugs lurking in it, and this module is no
+All complex software has bugs lurking in it, and this module is no
exception. If you find a bug please either email me, or add the bug
to cpan-RT.
requires 'build_options';
1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+MooseX::Getopt::Parser - A Moose role for MooseX::Getopt's parser
+
+=head1 SYNOPSIS
+
+ package MooseX::Getopt::Parser::Descriptive;
+ use Moose;
+ with 'MooseX::Getopt::Parser';
+ 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 = {};
+
+ # your code is here
+
+ return $options;
+ }
+
+=head1 DESCRIPTION
+
+This is a L<Moose> role for L<MooseX::Getopt>'s parser. The parser have
+to implement C<build_options> method which takes a
+L<MooseX::Getopt::Session> object and attributes list which will be
+filled by parser.
+
+=head1 BUGS
+
+All complex software has bugs lurking in it, and this module is no
+exception. If you find a bug please either email me, or add the bug
+to cpan-RT.
+
+=head1 SEE ALSO
+
+=over 4
+
+=item L<MooseX::Getopt>
+
+=item L<MooseX::Getopt::Parser::Long>
+
+=item L<MooseX::Getopt::Parser::Descriptive>
+
+=item L<MooseX::Getopt::Parser::Default>
+
+=back
+
+=head1 AUTHOR
+
+Piotr Roszatycki, E<lt>dexter@cpan.orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2007-2008 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
--- /dev/null
+
+package MooseX::Getopt::Parser::Default;
+
+use Moose;
+
+use MooseX::Getopt::Parser::Long;
+use maybe 'MooseX::Getopt::Parser::Descriptive';
+
+
+sub new {
+ my $class = shift;
+ return maybe::HAVE_MOOSEX_GETOPT_PARSER_DESCRIPTIVE
+ ? MooseX::Getopt::Parser::Descriptive->new(@_)
+ : MooseX::Getopt::Parser::Long->new(@_);
+};
+
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+MooseX::Getopt::Parser::Default - A default parser for MooseX::Getopt
+
+=head1 SYNOPSIS
+
+ use MooseX::Getopt::Parser::Default;
+
+ my $parser = MooseX::Getopt::Parser::Default->new( config => ['pass_through'] );
+ my $getopt = MooseX::Getopt::Session->new( parser => $parser );
+ my $app = My::App->new( getopt => $getopt );
+
+=head1 DESCRIPTION
+
+This class contains the factory method which returns new
+L<MooseX::Getopt::Parser> object. The object's class is
+L<MooseX::Getopt::Parser::Descriptive> if L<Getopt::Long::Descriptive>
+module exists or L<MooseX::Getopt::Parser::Long> otherwise.
+
+=head1 METHODS
+
+=over 4
+
+=item B<new (%params)>
+
+This is the factory method which returns new L<MooseX::Getopt::Parser>
+object. All C<%params> are passed to new object.
+
+=back
+
+=head1 BUGS
+
+All complex software has bugs lurking in it, and this module is no
+exception. If you find a bug please either email me, or add the bug
+to cpan-RT.
+
+=head1 SEE ALSO
+
+=over 4
+
+=item L<MooseX::Getopt::Parser>
+
+=item L<MooseX::Getopt::Parser::Long>
+
+=item L<MooseX::Getopt::Parser::Descriptive>
+
+=back
+
+=head1 AUTHOR
+
+Piotr Roszatycki, E<lt>dexter@cpan.orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2007-2008 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
use Getopt::Long::Descriptive;
use MooseX::Getopt::OptionTypeMap;
-#use Smart::Comments;
# Special configuration for parser
-has 'config' => (
+has config => (
is => 'rw',
isa => 'ArrayRef[Str]',
auto_deref => 1,
);
# Format for usage description
-has 'format' => (
+has format => (
is => 'rw',
isa => 'Str',
default => 'usage: %c %o',
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;
+ $cmd_flags_to_names{$flag} = $name;
my $opt_string = join '|', $flag, @aliases;
$opt_string .= MooseX::Getopt::OptionTypeMap->get_option_type($type) if $type;
];
};
- ### MooseX::Getopt::Parser::Descriptive::build_options @opts : @opts
+ my $warnings = '';
GETOPT: {
- local @ARGV = $getopt->argv;
- ### MooseX::Getopt::Parser::Descriptive::build_options @ARGV : @ARGV
+ local @ARGV = @{ $getopt->ARGV };
local $SIG{__WARN__} = sub {
return warn @_ if $_[0]=~/^\###/; # Smart::Comments
- $getopt->strcat_warning( $_[0] )
+ $warnings .= $_[0];
};
eval {
);
};
my $e = $@;
- $getopt->strcat_warning( $e ) if $e;
- $getopt->status( ! $e );
+ $warnings .= $e if $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 { $cmd_flags_to_names{$_} => $options->{$_} } keys %$options };
- #%options = map { $_ => $options{$_} } grep { defined $options{$_} } keys %options;
$getopt->options( $options );
- ### 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->has_warning || !$getopt->status);
+ die $warnings if $warnings;
return $options;
};
1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+MooseX::Getopt::Parser::Descriptive - A Getopt::Long::Descriptive parser for MooseX::Getopt
+
+=head1 SYNOPSIS
+
+ use MooseX::Getopt::Parser::Descriptive;
+
+ my $parser = MooseX::Getopt::Parser::Descriptive->new(
+ format => 'Usage: %c %o',
+ config => ['pass_through']
+ );
+ my $getopt = MooseX::Getopt::Session->new( parser => $parser );
+ my $app = My::App->new( getopt => $getopt );
+
+=head1 DESCRIPTION
+
+This class does L<MooseX::Getopt::Parser> for L<MooseX::Getopt>. This
+class is used by default if L<Getopt::Long::Descriptive> module is
+missing.
+
+=head1 METHODS
+
+=over 4
+
+=item B<build_options ($getopt, @attrs)>
+
+This method parses the CLI options with L<Getopt::Long> and returns a hashref to options list.
+
+The first argument have to be L<MooseX::Getopt::Session> object and
+second argument is a list of attributes which contains options.
+
+=item B<config>
+
+This accessor contains the arrayref to list with special configuration
+keywords for L<Getopt::Long>.
+
+=item B<format>
+
+This accessor contains the string with message printed by
+L<Getopt::Long::Descriptive> if error is occured.
+
+=back
+
+=head1 BUGS
+
+All complex software has bugs lurking in it, and this module is no
+exception. If you find a bug please either email me, or add the bug
+to cpan-RT.
+
+=head1 SEE ALSO
+
+=over 4
+
+=item L<MooseX::Getopt::Parser>
+
+=item L<MooseX::Getopt::Parser::Default>
+
+=item L<MooseX::Getopt::Parser::Long>
+
+=item L<Getopt::Long::Descriptive>
+
+=back
+
+=head1 AUTHOR
+
+Piotr Roszatycki, E<lt>dexter@cpan.orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2007-2008 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
use Getopt::Long;
use MooseX::Getopt::OptionTypeMap;
-#use Smart::Comments;
# Special configuration for parser
-has 'config' => (
+has config => (
is => 'rw',
isa => 'ArrayRef[Str]',
auto_deref => 1,
Moose->throw_error('First argument is not a MooseX::Getopt::Session')
unless $getopt->isa('MooseX::Getopt::Session');
- my %options;
+ my $options = {};
my @opts;
foreach my $attr (@attrs) {
my $opt_string = join '|', $flag, @aliases;
$opt_string .= MooseX::Getopt::OptionTypeMap->get_option_type($type) if $type;
- $options{$name} = undef;
- push @opts, $opt_string => \$options{$name};
+ $options->{$name} = undef;
+ push @opts, $opt_string => \$options->{$name};
};
- ### MooseX::Getopt::Parser::Long::build_options @opts : @opts
+ my $warnings = '';
GETOPT: {
my $parser = new Getopt::Long::Parser;
$parser->configure( $self->config );
- local @ARGV = $getopt->argv;
- ### MooseX::Getopt::Parser::Long::build_options @ARGV : @ARGV
+ local @ARGV = @{ $getopt->ARGV };
local $SIG{__WARN__} = sub {
return warn @_ if $_[0]=~/^\###/; # Smart::Comments
- $getopt->strcat_warning( $_[0] )
+ $warnings .= $_[0];
};
- my $status = $parser->getoptions( @opts );
- $getopt->status( $status );
+ $parser->getoptions( @opts );
my $extra_argv = \@ARGV;
$getopt->extra_argv( $extra_argv );
};
- %options = map { $_ => $options{$_} } grep { defined $options{$_} } keys %options;
- $getopt->options( \%options );
+ # Filter not defined values in options hashref
+ $options = { map { $_ => $options->{$_} } grep { defined $options->{$_} } keys %$options };
- die join '', $getopt->warning if $getopt->has_warning;
+ $getopt->options( $options );
- ### MooseX::Getopt::Parser::Long::build_options %options : %options
- return \%options;
+ die $warnings if $warnings;
+
+ return $options;
};
1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+MooseX::Getopt::Parser::Long - A Getopt::Long parser for MooseX::Getopt
+
+=head1 SYNOPSIS
+
+ use MooseX::Getopt::Parser::Long;
+
+ my $parser = MooseX::Getopt::Parser::Long->new( config => ['pass_through'] );
+ my $getopt = MooseX::Getopt::Session->new( parser => $parser );
+ my $app = My::App->new( getopt => $getopt );
+
+=head1 DESCRIPTION
+
+This class does L<MooseX::Getopt::Parser> for L<MooseX::Getopt>. This
+class is used by default if L<Getopt::Long::Descriptive> module is
+missing.
+
+=head1 METHODS
+
+=over 4
+
+=item B<build_options ($getopt, @attrs)>
+
+This method parses the CLI options with L<Getopt::Long> and returns a hashref to options list.
+
+The first argument have to be L<MooseX::Getopt::Session> object and
+second argument is a list of attributes which contains options.
+
+=item B<config>
+
+This accessor contains the arrayref to list with special configuration
+keywords for L<Getopt::Long>.
+
+=back
+
+=head1 BUGS
+
+All complex software has bugs lurking in it, and this module is no
+exception. If you find a bug please either email me, or add the bug
+to cpan-RT.
+
+=head1 SEE ALSO
+
+=over 4
+
+=item L<MooseX::Getopt::Parser>
+
+=item L<MooseX::Getopt::Parser::Default>
+
+=item L<MooseX::Getopt::Parser::Descriptive>
+
+=item L<Getopt::Long>
+
+=back
+
+=head1 AUTHOR
+
+Piotr Roszatycki, E<lt>dexter@cpan.orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2007-2008 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
use Moose;
-use MooseX::Getopt::Parser::Long;
-use maybe 'MooseX::Getopt::Parser::Descriptive';
+use MooseX::Getopt::Parser::Default;
+
+
+use constant _default_getopt_parser => 'MooseX::Getopt::Parser::Default';
-#use Smart::Comments;
# Pluggined MooseX::Getopt::Parser parser
-has '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
- },
+ default => sub { $_[0]->_default_getopt_parser->new },
);
# Filter for classes which are searched for getopt trait
-has 'classes_filter' => (
+has classes_filter => (
is => 'rw',
isa => 'CodeRef',
default => sub { sub { 1 } },
);
# Explicite parameters for new_with_options
-has 'params' => (
+has params => (
is => 'rw',
isa => 'HashRef',
default => sub { {} },
);
# Original @ARGV values
-has 'argv' => (
+has ARGV => (
is => 'rw',
isa => 'ArrayRef[Str]',
- auto_deref => 1,
default => sub { [ @ARGV ] },
);
# Unrecognized @ARGV values
-has 'extra_argv' => (
+has extra_argv => (
is => 'rw',
isa => 'ArrayRef[Str]',
- auto_deref => 1,
default => sub { [] },
);
# Hash with options parsed from argv
-has 'options' => (
+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
sub BUILD {
- ### MooseX::Getopt::Session::BUILD : @_
my ($self, $args) = @_;
$self->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->parser->build_options( $self, @attrs );
}
my ($self, $attr) = @_;
my $type;
-
+
$type = $attr->type_constraint if $attr->has_type_constraint;
if ($attr->does('MooseX::Getopt::Meta::Attribute::Trait')) {
};
-sub strcat_warning {
- my ($self, $string) = @_;
+1;
- return $self->warning( ($self->has_warning ? $self->warning : '') . $string );
-};
+__END__
+=pod
-1;
+=head1 NAME
+
+MooseX::Getopt::Session - A CLI session for MooseX::Getopt
+
+=head1 SYNOPSIS
+
+ ## in your script
+ #!/usr/bin/perl
+
+ use My::App;
+
+ my $getopt = MooseX::Getopt::Session->new;
+
+ my $app = My::App->new_with_options( getopt => $getopt );
+ my $cmd = My::App::Cmd->new_with_options( getopt => $getopt );
+
+=head1 DESCRIPTION
+
+This class handles CLI session for L<MooseX::Getopt>. The session can
+be shared between more than one classes which does L<MooseX::Getopt>.
+If C<getopt> parameter is missing, new session is created for one class.
+
+The L<MooseX::Getopt::Session> scans all classes and gets these which do
+L<MooseX::Getopt>. These classes will make an option list for
+L<MooseX::Getopt::Parser>.
+
+=head1 METHODS
+
+=over 4
+
+=item B<new (%params)>
+
+This method creates new CLI session for L<MooseX::Getopt> and calls
+C<build_options> method.
+
+=item B<build_options>
+
+This method creates the list of attributes which contains options and
+calls C<build_options> method from L<MooseX::Getopt::Parser> with this
+object and attributes list as parameters.
+
+=item B<parser>
+
+This accessor contains a parser object which does
+L<MooseX::Getopt::Parser>. It can be set explicite, i.e. if you need to
+modify the way parser works, or new object via
+L<MooseX::Getopt::Parser::Default> factory will be created.
+
+=item B<classes_filter>
+
+This accessor contains a coderef with classes filter which is used for
+searching proper classes to create options list. The filter passes any
+class by default but L<MooseX::Getopt> will search the attributes only
+in own class, if new session is created implicity.
+
+=item B<params>
+
+This accessor contains the parameters which will be included to each
+L<MooseX::Getopt>->new_with_options call.
+
+=item B<ARGV>
+
+This accessor contains a reference to a copy of the C<@ARGV> array as it
+originally existed at the time of C<new_with_options>.
+
+=item B<extra_argv>
+
+This accessor contains an arrayref of leftover C<@ARGV> elements that
+L<Getopt::Long> did not parse. Note that the real C<@ARGV> is left
+un-mangled.
+
+=item B<options>
+
+This accessor contains an arrayref of options parsed from command line
+by L<MooseX::Getopt::Parser>.
+
+=item B<BUILD>
+
+This is a default L<Moose> constructor.
+
+=item B<meta>
+
+This returns the role meta object.
+
+=back
+
+=head1 SEE ALSO
+
+=over 4
+
+=item L<MooseX::Getopt>
+
+=item L<MooseX::Getopt::Parser>
+
+=back
+
+=head1 BUGS
+
+All complex software has bugs lurking in it, and this module is no
+exception. If you find a bug please either email me, or add the bug
+to cpan-RT.
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+Brandon L. Black, E<lt>blblack@gmail.comE<gt>
+
+Yuval Kogman, E<lt>nothingmuch@woobling.orgE<gt>
+
+=head1 CONTRIBUTORS
+
+Ryan D Johnson, E<lt>ryan@innerfence.comE<gt>
+
+Piotr Roszatycki, E<lt>dexter@cpan.orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2007-2008 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
around '_compute_getopt_attrs' => sub {
my $next = shift;
my ($class, @args) = @_;
-
- return grep {
- $_->does('MooseX::Getopt::Meta::Attribute::Trait')
+
+ return grep {
+ $_->does('MooseX::Getopt::Meta::Attribute::Trait')
} $class->$next(@args);
};
=head1 NAME
MooseX::Getopt::Strict - only make options for attrs with the Getopt metaclass
-
+
=head1 DESCRIPTION
-This is an stricter version of C<MooseX::Getopt> which only processes the
+This is an stricter version of C<MooseX::Getopt> which only processes the
attributes if they explicitly set as C<Getopt> attributes. All other attributes
are ignored by the command line handler.
-
+
=head1 METHODS
=over 4
=back
+=head1 SEE ALSO
+
+=over 4
+
+=item L<MooseX::Getopt>
+
+=back
+
=head1 BUGS
-All complex software has bugs lurking in it, and this module is no
+All complex software has bugs lurking in it, and this module is no
exception. If you find a bug please either email me, or add the bug
to cpan-RT.
use strict;
use warnings;
-use Test::More tests => 185;
+use Test::More tests => 263;
BEGIN {
use_ok('MooseX::Getopt');
can_ok($attr, 'cmd_aliases');
}
-foreach my $parser_name (qw(MooseX::Getopt::Parser::Long MooseX::Getopt::Parser::Descriptive)) {
+foreach my $parser_name (qw(MooseX::Getopt::Parser::Long MooseX::Getopt::Parser::Descriptive MooseX::Getopt::Parser::Default)) {
SKIP: {
if ($parser_name eq 'MooseX::Getopt::Parser::Descriptive') {
eval { require Getopt::Long::Descriptive };
local @ARGV = ();
my $parser = $parser_name->new;
- isa_ok($parser, $parser_name);
+ ok(ref($parser) =~ /^MooseX::Getopt::Parser::/, '... parser object is created');
my $getopt = MooseX::Getopt::Session->new( parser => $parser );
isa_ok($getopt, 'MooseX::Getopt::Session');
local @ARGV = ('--verbose', '--length', 50);
my $parser = $parser_name->new;
- isa_ok($parser, $parser_name);
+ ok(ref($parser) =~ /^MooseX::Getopt::Parser::/, '... parser object is created');
my $getopt = MooseX::Getopt::Session->new( parser => $parser );
isa_ok($getopt, 'MooseX::Getopt::Session');
local @ARGV = ('--verbose', '-f', 'foo.txt');
my $parser = $parser_name->new;
- isa_ok($parser, $parser_name);
+ ok(ref($parser) =~ /^MooseX::Getopt::Parser::/, '... parser object is created');
my $getopt = MooseX::Getopt::Session->new( parser => $parser );
isa_ok($getopt, 'MooseX::Getopt::Session');
local @ARGV = ('--verbose', '--libs', 'libs/', '--libs', 'includes/lib');
my $parser = $parser_name->new;
- isa_ok($parser, $parser_name);
+ ok(ref($parser) =~ /^MooseX::Getopt::Parser::/, '... parser object is created');
my $getopt = MooseX::Getopt::Session->new( parser => $parser );
isa_ok($getopt, 'MooseX::Getopt::Session');
local @ARGV = ('--details', 'os=mac', '--details', 'name=foo');
my $parser = $parser_name->new;
- isa_ok($parser, $parser_name);
+ ok(ref($parser) =~ /^MooseX::Getopt::Parser::/, '... parser object is created');
my $getopt = MooseX::Getopt::Session->new( parser => $parser );
isa_ok($getopt, 'MooseX::Getopt::Session');
local @ARGV = ('--noverbose');
my $parser = $parser_name->new;
- isa_ok($parser, $parser_name);
+ ok(ref($parser) =~ /^MooseX::Getopt::Parser::/, '... parser object is created');
my $getopt = MooseX::Getopt::Session->new( parser => $parser );
isa_ok($getopt, 'MooseX::Getopt::Session');
local @ARGV = ('--cow', '42');
my $parser = $parser_name->new;
- isa_ok($parser, $parser_name);
+ ok(ref($parser) =~ /^MooseX::Getopt::Parser::/, '... parser object is created');
my $getopt = MooseX::Getopt::Session->new( parser => $parser );
isa_ok($getopt, 'MooseX::Getopt::Session');
local @ARGV = ('--moocow', '88');
my $parser = $parser_name->new;
- isa_ok($parser, $parser_name);
+ ok(ref($parser) =~ /^MooseX::Getopt::Parser::/, '... parser object is created');
my $getopt = MooseX::Getopt::Session->new( parser => $parser );
isa_ok($getopt, 'MooseX::Getopt::Session');
local @ARGV = ('-c', '99');
my $parser = $parser_name->new;
- isa_ok($parser, $parser_name);
+ ok(ref($parser) =~ /^MooseX::Getopt::Parser::/, '... parser object is created');
my $getopt = MooseX::Getopt::Session->new( parser => $parser );
isa_ok($getopt, 'MooseX::Getopt::Session');
local @ARGV = ('--horsey', '123');
my $parser = $parser_name->new;
- isa_ok($parser, $parser_name);
+ ok(ref($parser) =~ /^MooseX::Getopt::Parser::/, '... parser object is created');
my $getopt = MooseX::Getopt::Session->new( parser => $parser );
isa_ok($getopt, 'MooseX::Getopt::Session');
local @ARGV = ('-x', '321');
my $parser = $parser_name->new;
- isa_ok($parser, $parser_name);
+ ok(ref($parser) =~ /^MooseX::Getopt::Parser::/, '... parser object is created');
my $getopt = MooseX::Getopt::Session->new( parser => $parser );
isa_ok($getopt, 'MooseX::Getopt::Session');
local @ARGV = ('-p', '666');
my $parser = $parser_name->new;
- isa_ok($parser, $parser_name);
+ ok(ref($parser) =~ /^MooseX::Getopt::Parser::/, '... parser object is created');
my $getopt = MooseX::Getopt::Session->new( parser => $parser );
isa_ok($getopt, 'MooseX::Getopt::Session');
local @ARGV = @args;
my $parser = $parser_name->new;
- isa_ok($parser, $parser_name);
+ ok(ref($parser) =~ /^MooseX::Getopt::Parser::/, '... parser object is created');
my $getopt = MooseX::Getopt::Session->new( parser => $parser );
isa_ok($getopt, 'MooseX::Getopt::Session');
use strict;
use warnings;
-use Test::More tests => 21;
+use Test::More tests => 31;
BEGIN {
use_ok('MooseX::Getopt');
}
-foreach my $parser_name (qw(MooseX::Getopt::Parser::Long MooseX::Getopt::Parser::Descriptive)) {
+foreach my $parser_name (qw(MooseX::Getopt::Parser::Long MooseX::Getopt::Parser::Descriptive MooseX::Getopt::Parser::Default)) {
SKIP: {
if ($parser_name eq 'MooseX::Getopt::Parser::Descriptive') {
eval { require Getopt::Long::Descriptive };
local @ARGV = ();
my $parser = $parser_name->new;
- isa_ok($parser, $parser_name);
+ ok(ref($parser) =~ /^MooseX::Getopt::Parser::/, '... parser object is created');
my $getopt = MooseX::Getopt::Session->new( parser => $parser );
isa_ok($getopt, 'MooseX::Getopt::Session');
local @ARGV = ('--nums', 3, '--nums', 5);
my $parser = $parser_name->new;
- isa_ok($parser, $parser_name);
+ ok(ref($parser) =~ /^MooseX::Getopt::Parser::/, '... parser object is created');
my $getopt = MooseX::Getopt::Session->new( parser => $parser );
isa_ok($getopt, 'MooseX::Getopt::Session');
local @ARGV = ('--nums', 3, '--nums', 'foo');
my $parser = $parser_name->new;
- isa_ok($parser, $parser_name);
+ ok(ref($parser) =~ /^MooseX::Getopt::Parser::/, '... parser object is created');
my $getopt = MooseX::Getopt::Session->new( parser => $parser );
isa_ok($getopt, 'MooseX::Getopt::Session');
use strict;
use warnings;
-use Test::More tests => 17;
+use Test::More tests => 25;
BEGIN {
use_ok('MooseX::Getopt');
}
-foreach my $parser_name (qw(MooseX::Getopt::Parser::Long MooseX::Getopt::Parser::Descriptive)) {
+foreach my $parser_name (qw(MooseX::Getopt::Parser::Long MooseX::Getopt::Parser::Descriptive MooseX::Getopt::Parser::Default)) {
SKIP: {
if ($parser_name eq 'MooseX::Getopt::Parser::Descriptive') {
eval { require Getopt::Long::Descriptive };
local @ARGV = ();
my $parser = $parser_name->new;
- isa_ok($parser, $parser_name);
+ ok(ref($parser) =~ /^MooseX::Getopt::Parser::/, '... parser object is created');
my $getopt = MooseX::Getopt::Session->new( parser => $parser );
isa_ok($getopt, 'MooseX::Getopt::Session');
local @ARGV = ('--nums', 3, '--nums', 5);
my $parser = $parser_name->new;
- isa_ok($parser, $parser_name);
+ ok(ref($parser) =~ /^MooseX::Getopt::Parser::/, '... parser object is created');
my $getopt = MooseX::Getopt::Session->new( parser => $parser );
isa_ok($getopt, 'MooseX::Getopt::Session');
use strict;
use warnings;
-use Test::More tests => 23;
+use Test::More tests => 34;
use Test::Exception;
BEGIN {
}
-foreach my $parser_name (qw(MooseX::Getopt::Parser::Long MooseX::Getopt::Parser::Descriptive)) {
+foreach my $parser_name (qw(MooseX::Getopt::Parser::Long MooseX::Getopt::Parser::Descriptive MooseX::Getopt::Parser::Default)) {
SKIP: {
if ($parser_name eq 'MooseX::Getopt::Parser::Descriptive') {
eval { require Getopt::Long::Descriptive };
local @ARGV = ();
my $parser = $parser_name->new;
- isa_ok($parser, $parser_name);
+ ok(ref($parser) =~ /^MooseX::Getopt::Parser::/, '... parser object is created');
my $getopt = MooseX::Getopt::Session->new( parser => $parser );
isa_ok($getopt, 'MooseX::Getopt::Session');
throws_ok {
my $parser = $parser_name->new;
- isa_ok($parser, $parser_name);
+ ok(ref($parser) =~ /^MooseX::Getopt::Parser::/, '... parser object is created');
my $getopt = MooseX::Getopt::Session->new( parser => $parser );
isa_ok($getopt, 'MooseX::Getopt::Session');
use strict;
use warnings;
-use Test::More tests => 27;
+use Test::More tests => 40;
use Test::Exception;
BEGIN {
}
-foreach my $parser_name (qw(MooseX::Getopt::Parser::Long MooseX::Getopt::Parser::Descriptive)) {
+foreach my $parser_name (qw(MooseX::Getopt::Parser::Long MooseX::Getopt::Parser::Descriptive MooseX::Getopt::Parser::Default)) {
SKIP: {
if ($parser_name eq 'MooseX::Getopt::Parser::Descriptive') {
eval { require Getopt::Long::Descriptive };
local @ARGV = ();
my $parser = $parser_name->new;
- isa_ok($parser, $parser_name);
+ ok(ref($parser) =~ /^MooseX::Getopt::Parser::/, '... parser object is created');
my $getopt = MooseX::Getopt::Session->new( parser => $parser );
isa_ok($getopt, 'MooseX::Getopt::Session');
throws_ok {
my $parser = $parser_name->new;
- isa_ok($parser, $parser_name);
+ ok(ref($parser) =~ /^MooseX::Getopt::Parser::/, '... parser object is created');
my $getopt = MooseX::Getopt::Session->new( parser => $parser );
isa_ok($getopt, 'MooseX::Getopt::Session');
throws_ok {
my $parser = $parser_name->new;
- isa_ok($parser, $parser_name);
+ ok(ref($parser) =~ /^MooseX::Getopt::Parser::/, '... parser object is created');
my $getopt = MooseX::Getopt::Session->new( parser => $parser );
isa_ok($getopt, 'MooseX::Getopt::Session');
use strict;
use warnings;
-use Test::More tests => 173;
+use Test::More tests => 251;
use Test::Moose;
BEGIN {
can_ok($attr, 'cmd_aliases');
}
-foreach my $parser_name (qw(MooseX::Getopt::Parser::Long MooseX::Getopt::Parser::Descriptive)) {
+foreach my $parser_name (qw(MooseX::Getopt::Parser::Long MooseX::Getopt::Parser::Descriptive MooseX::Getopt::Parser::Default)) {
SKIP: {
if ($parser_name eq 'MooseX::Getopt::Parser::Descriptive') {
eval { require Getopt::Long::Descriptive };
local @ARGV = ();
my $parser = $parser_name->new;
- isa_ok($parser, $parser_name);
+ ok(ref($parser) =~ /^MooseX::Getopt::Parser::/, '... parser object is created');
my $getopt = MooseX::Getopt::Session->new( parser => $parser );
isa_ok($getopt, 'MooseX::Getopt::Session');
local @ARGV = ('--verbose', '--length', 50);
my $parser = $parser_name->new;
- isa_ok($parser, $parser_name);
+ ok(ref($parser) =~ /^MooseX::Getopt::Parser::/, '... parser object is created');
my $getopt = MooseX::Getopt::Session->new( parser => $parser );
isa_ok($getopt, 'MooseX::Getopt::Session');
local @ARGV = ('--verbose', '-f', 'foo.txt');
my $parser = $parser_name->new;
- isa_ok($parser, $parser_name);
+ ok(ref($parser) =~ /^MooseX::Getopt::Parser::/, '... parser object is created');
my $getopt = MooseX::Getopt::Session->new( parser => $parser );
isa_ok($getopt, 'MooseX::Getopt::Session');
local @ARGV = ('--verbose', '--libs', 'libs/', '--libs', 'includes/lib');
my $parser = $parser_name->new;
- isa_ok($parser, $parser_name);
+ ok(ref($parser) =~ /^MooseX::Getopt::Parser::/, '... parser object is created');
my $getopt = MooseX::Getopt::Session->new( parser => $parser );
isa_ok($getopt, 'MooseX::Getopt::Session');
local @ARGV = ('--details', 'os=mac', '--details', 'name=foo');
my $parser = $parser_name->new;
- isa_ok($parser, $parser_name);
+ ok(ref($parser) =~ /^MooseX::Getopt::Parser::/, '... parser object is created');
my $getopt = MooseX::Getopt::Session->new( parser => $parser );
isa_ok($getopt, 'MooseX::Getopt::Session');
local @ARGV = ('--noverbose');
my $parser = $parser_name->new;
- isa_ok($parser, $parser_name);
+ ok(ref($parser) =~ /^MooseX::Getopt::Parser::/, '... parser object is created');
my $getopt = MooseX::Getopt::Session->new( parser => $parser );
isa_ok($getopt, 'MooseX::Getopt::Session');
local @ARGV = ('--cow', '42');
my $parser = $parser_name->new;
- isa_ok($parser, $parser_name);
+ ok(ref($parser) =~ /^MooseX::Getopt::Parser::/, '... parser object is created');
my $getopt = MooseX::Getopt::Session->new( parser => $parser );
isa_ok($getopt, 'MooseX::Getopt::Session');
local @ARGV = ('--moocow', '88');
my $parser = $parser_name->new;
- isa_ok($parser, $parser_name);
+ ok(ref($parser) =~ /^MooseX::Getopt::Parser::/, '... parser object is created');
my $getopt = MooseX::Getopt::Session->new( parser => $parser );
isa_ok($getopt, 'MooseX::Getopt::Session');
local @ARGV = ('-c', '99');
my $parser = $parser_name->new;
- isa_ok($parser, $parser_name);
+ ok(ref($parser) =~ /^MooseX::Getopt::Parser::/, '... parser object is created');
my $getopt = MooseX::Getopt::Session->new( parser => $parser );
isa_ok($getopt, 'MooseX::Getopt::Session');
local @ARGV = ('--horsey', '123');
my $parser = $parser_name->new;
- isa_ok($parser, $parser_name);
+ ok(ref($parser) =~ /^MooseX::Getopt::Parser::/, '... parser object is created');
my $getopt = MooseX::Getopt::Session->new( parser => $parser );
isa_ok($getopt, 'MooseX::Getopt::Session');
local @ARGV = ('-x', '321');
my $parser = $parser_name->new;
- isa_ok($parser, $parser_name);
+ ok(ref($parser) =~ /^MooseX::Getopt::Parser::/, '... parser object is created');
my $getopt = MooseX::Getopt::Session->new( parser => $parser );
isa_ok($getopt, 'MooseX::Getopt::Session');
local @ARGV = ('-p', '666');
my $parser = $parser_name->new;
- isa_ok($parser, $parser_name);
+ ok(ref($parser) =~ /^MooseX::Getopt::Parser::/, '... parser object is created');
my $getopt = MooseX::Getopt::Session->new( parser => $parser );
isa_ok($getopt, 'MooseX::Getopt::Session');
local @ARGV = @args;
my $parser = $parser_name->new;
- isa_ok($parser, $parser_name);
+ ok(ref($parser) =~ /^MooseX::Getopt::Parser::/, '... parser object is created');
my $getopt = MooseX::Getopt::Session->new( parser => $parser );
isa_ok($getopt, 'MooseX::Getopt::Session');
use strict;
use warnings;
-use Test::More tests => 23;
+use Test::More tests => 34;
use Test::Exception;
BEGIN {
}
-foreach my $parser_name (qw(MooseX::Getopt::Parser::Long MooseX::Getopt::Parser::Descriptive)) {
+foreach my $parser_name (qw(MooseX::Getopt::Parser::Long MooseX::Getopt::Parser::Descriptive MooseX::Getopt::Parser::Default)) {
SKIP: {
if ($parser_name eq 'MooseX::Getopt::Parser::Descriptive') {
eval { require Getopt::Long::Descriptive };
local @ARGV = ();
my $parser = $parser_name->new;
- isa_ok($parser, $parser_name);
+ ok(ref($parser) =~ /^MooseX::Getopt::Parser::/, '... parser object is created');
my $getopt = MooseX::Getopt::Session->new( parser => $parser );
isa_ok($getopt, 'MooseX::Getopt::Session');
throws_ok {
my $parser = $parser_name->new;
- isa_ok($parser, $parser_name);
+ ok(ref($parser) =~ /^MooseX::Getopt::Parser::/, '... parser object is created');
my $getopt = MooseX::Getopt::Session->new( parser => $parser );
isa_ok($getopt, 'MooseX::Getopt::Session');
BEGIN {
eval 'use Getopt::Long::Descriptive;';
plan skip_all => "Getopt::Long::Descriptive required for this test" if $@;
- plan tests => 5;
+ plan tests => 5;
use_ok('MooseX::Getopt');
}
{
package Engine::Foo;
use Moose;
-
+
with 'MooseX::Getopt';
-
+
has 'nproc' => (
metaclass => 'Getopt',
is => 'ro',
is($foo->nproc, 1, '... got the right value (1), without GLD needing to handle defaults');
}
-
-
-
projects / gitmo/MooseX-Getopt.git / commitdiff