From: Tomas Doran Date: Thu, 26 Nov 2009 02:59:12 +0000 (+0000) Subject: Properly pull apart into roles X-Git-Tag: 0.25~5 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=33edcaa4819f23f5c92f2f4db8b0163866156d22;p=gitmo%2FMooseX-Getopt.git Properly pull apart into roles --- diff --git a/lib/MooseX/Getopt.pm b/lib/MooseX/Getopt.pm index 3e28e45..f3636f3 100644 --- a/lib/MooseX/Getopt.pm +++ b/lib/MooseX/Getopt.pm @@ -1,258 +1,12 @@ - package MooseX::Getopt; use Moose::Role; -use MooseX::Getopt::OptionTypeMap; -use MooseX::Getopt::Meta::Attribute; -use MooseX::Getopt::Meta::Attribute::NoGetopt; - -use Carp (); - -use Getopt::Long (); # GLD uses it anyway, doesn't hurt use constant HAVE_GLD => not not eval { require Getopt::Long::Descriptive }; our $VERSION = '0.25'; our $AUTHORITY = 'cpan:STEVAN'; -has ARGV => (is => 'rw', isa => 'ArrayRef', metaclass => "NoGetopt"); -has extra_argv => (is => 'rw', isa => 'ArrayRef', metaclass => "NoGetopt"); - -sub new_with_options { - my ($class, @params) = @_; - - my $config_from_file; - if($class->meta->does_role('MooseX::ConfigFromFile')) { - local @ARGV = @ARGV; - - my $configfile; - my $opt_parser = Getopt::Long::Parser->new( config => [ qw( pass_through ) ] ); - $opt_parser->getoptions( "configfile=s" => \$configfile ); - - if(!defined $configfile) { - my $cfmeta = $class->meta->find_attribute_by_name('configfile'); - $configfile = $cfmeta->default if $cfmeta->has_default; - if (ref $configfile eq 'CODE') { - # not sure theres a lot you can do with the class and may break some assumptions - # warn? - $configfile = &$configfile($class); - } - if (defined $configfile) { - $config_from_file = eval { - $class->get_config_from_file($configfile); - }; - if ($@) { - die $@ unless $@ =~ /Specified configfile '\Q$configfile\E' does not exist/; - } - } - } - else { - $config_from_file = $class->get_config_from_file($configfile); - } - } - - my $constructor_params = ( @params == 1 ? $params[0] : {@params} ); - - Carp::croak("Single parameters to new_with_options() must be a HASH ref") - unless ref($constructor_params) eq 'HASH'; - - my %processed = $class->_parse_argv( - options => [ - $class->_attrs_to_options( $config_from_file ) - ], - params => $constructor_params, - ); - - my $params = $config_from_file ? { %$config_from_file, %{$processed{params}} } : $processed{params}; - - # did the user request usage information? - if ( $processed{usage} && ($params->{'?'} or $params->{help} or $params->{usage}) ) - { - $class->_getopt_full_usage($processed{usage}); - } - - $class->new( - ARGV => $processed{argv_copy}, - extra_argv => $processed{argv}, - %$constructor_params, # explicit params to ->new - %$params, # params from CLI - ); -} - -sub _parse_argv { - my ( $class, %params ) = @_; - - local @ARGV = @{ $params{params}{argv} || \@ARGV }; - - my ( $opt_spec, $name_to_init_arg ) = ( HAVE_GLD ? $class->_gld_spec(%params) : $class->_traditional_spec(%params) ); - - # Get a clean copy of the original @ARGV - my $argv_copy = [ @ARGV ]; - - my @warnings; - my ( $parsed_options, $usage ) = eval { - local $SIG{__WARN__} = sub { push @warnings, @_ }; - - if ( HAVE_GLD ) { - return Getopt::Long::Descriptive::describe_options($class->_usage_format(%params), @$opt_spec); - } else { - my %options; - Getopt::Long::GetOptions(\%options, @$opt_spec); - return ( \%options, undef ); - } - }; - - $class->_getopt_spec_warnings(@warnings) if @warnings; - $class->_getopt_spec_exception(\@warnings, $@) if $@; - - # Get a copy of the Getopt::Long-mangled @ARGV - my $argv_mangled = [ @ARGV ]; - - my %constructor_args = ( - map { - $name_to_init_arg->{$_} => $parsed_options->{$_} - } keys %$parsed_options, - ); - - return ( - params => \%constructor_args, - argv_copy => $argv_copy, - argv => $argv_mangled, - ( defined($usage) ? ( usage => $usage ) : () ), - ); -} - -sub _getopt_spec_warnings { } - -sub _getopt_spec_exception { - my ($self, $warnings, $exception) = @_; - die @$warnings, $exception; -} - -sub _getopt_full_usage { - my ($self, $usage) = @_; - $usage->die; -} - -sub _usage_format { - return "usage: %c %o"; -} - -sub _traditional_spec { - my ( $class, %params ) = @_; - - my ( @options, %name_to_init_arg, %options ); - - foreach my $opt ( @{ $params{options} } ) { - push @options, $opt->{opt_string}; - - 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 ); -} - -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}; - } - - return ( \@options, \%name_to_init_arg ); -} - -sub _compute_getopt_attrs { - my $class = shift; - grep { - $_->does("MooseX::Getopt::Meta::Attribute::Trait") - or - $_->name !~ /^_/ - } grep { - !$_->does('MooseX::Getopt::Meta::Attribute::Trait::NoGetopt') - } $class->meta->get_all_attributes -} - -sub _get_cmd_flags_for_attr { - my ( $class, $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 _attrs_to_options { - my $class = shift; - my $config_from_file = shift || {}; - - my @options; - - foreach my $attr ($class->_compute_getopt_attrs) { - my ( $flag, @aliases ) = $class->_get_cmd_flags_for_attr($attr); - - my $opt_string = join(q{|}, $flag, @aliases); - - if ($attr->name eq 'configfile') { - $opt_string .= '=s'; - } - elsif ($attr->has_type_constraint) { - my $type = $attr->type_constraint; - if (MooseX::Getopt::OptionTypeMap->has_option_type($type)) { - $opt_string .= MooseX::Getopt::OptionTypeMap->get_option_type($type) - } - } - - push @options, { - name => $flag, - init_arg => $attr->init_arg, - opt_string => $opt_string, - required => $attr->is_required && !$attr->has_default && !$attr->has_builder && !exists $config_from_file->{$attr->name}, - # NOTE: - # this "feature" was breaking because - # Getopt::Long::Descriptive would return - # the default value as if it was a command - # line flag, which would then override the - # one passed into a constructor. - # See 100_gld_default_bug.t for an example - # - SL - #( ( $attr->has_default && ( $attr->is_default_a_coderef xor $attr->is_lazy ) ) ? ( default => $attr->default({}) ) : () ), - ( $attr->has_documentation ? ( doc => $attr->documentation ) : () ), - } - } - - return @options; -} +with HAVE_GLD ? 'MooseX::Getopt::GLD' : 'MooseX::Getopt::Basic'; no Moose::Role; 1; @@ -502,6 +256,8 @@ Ryan D Johnson, Eryan@innerfence.comE Drew Taylor, Edrew@drewtaylor.comE +Tomas Doran, (t0m) C<< >> + =head1 COPYRIGHT AND LICENSE Copyright 2007-2008 by Infinity Interactive, Inc. diff --git a/lib/MooseX/Getopt/Basic.pm b/lib/MooseX/Getopt/Basic.pm index 5000746..721fd3f 100644 --- a/lib/MooseX/Getopt/Basic.pm +++ b/lib/MooseX/Getopt/Basic.pm @@ -1,3 +1,4 @@ + package MooseX::Getopt::Basic; use Moose::Role; @@ -6,28 +7,11 @@ use MooseX::Getopt::Meta::Attribute; use MooseX::Getopt::Meta::Attribute::NoGetopt; use Carp (); -use Getopt::Long (); # GLD uses it anyway, doesn't hurt - -our $VERSION = '0.20'; -our $AUTHORITY = 'cpan:STEVAN'; +use Getopt::Long (); has ARGV => (is => 'rw', isa => 'ArrayRef', metaclass => "NoGetopt"); has extra_argv => (is => 'rw', isa => 'ArrayRef', metaclass => "NoGetopt"); -# _getopt_spec() and _getoptions() are overrided by MooseX::Getopt::GLD. - -sub _getopt_spec { - my ($class, %params) = @_; - return $class->_traditional_spec(%params) -} - -sub _get_options { - my ($class, undef, $opt_spec) = @_; - my %options; - Getopt::Long::GetOptions(\%options, @$opt_spec); - return ( \%options, undef ); -} - sub new_with_options { my ($class, @params) = @_; @@ -42,16 +26,23 @@ sub new_with_options { if(!defined $configfile) { my $cfmeta = $class->meta->find_attribute_by_name('configfile'); $configfile = $cfmeta->default if $cfmeta->has_default; - } - - if (defined $configfile) { - $config_from_file = eval { - $class->get_config_from_file($configfile); - }; - if ($@) { - die $@ unless $@ =~ /Specified configfile '\Q$configfile\E' does not exist/; + if (ref $configfile eq 'CODE') { + # not sure theres a lot you can do with the class and may break some assumptions + # warn? + $configfile = &$configfile($class); + } + if (defined $configfile) { + $config_from_file = eval { + $class->get_config_from_file($configfile); + }; + if ($@) { + die $@ unless $@ =~ /Specified configfile '\Q$configfile\E' does not exist/; + } } } + else { + $config_from_file = $class->get_config_from_file($configfile); + } } my $constructor_params = ( @params == 1 ? $params[0] : {@params} ); @@ -71,7 +62,7 @@ sub new_with_options { # did the user request usage information? if ( $processed{usage} && ($params->{'?'} or $params->{help} or $params->{usage}) ) { - $class->_exit_with_usage($processed{usage}); + $class->_getopt_full_usage($processed{usage}); } $class->new( @@ -82,10 +73,7 @@ sub new_with_options { ); } -sub _exit_with_usage { - my ($self, $usage) = @_; - $usage->die(); -} +sub _getopt_spec { shift->_traditional_spec(@_); } sub _parse_argv { my ( $class, %params ) = @_; @@ -97,15 +85,15 @@ sub _parse_argv { # Get a clean copy of the original @ARGV my $argv_copy = [ @ARGV ]; - my @err; - + my @warnings; my ( $parsed_options, $usage ) = eval { - local $SIG{__WARN__} = sub { push @err, @_ }; + local $SIG{__WARN__} = sub { push @warnings, @_ }; - return $class->_get_options(\%params, $opt_spec); + return $class->_getopt_get_options(\%params, $opt_spec); }; - die join "", grep { defined } @err, $@ if @err or $@; + $class->_getopt_spec_warnings(@warnings) if @warnings; + $class->_getopt_spec_exception(\@warnings, $@) if $@; # Get a copy of the Getopt::Long-mangled @ARGV my $argv_mangled = [ @ARGV ]; @@ -124,6 +112,25 @@ sub _parse_argv { ); } +sub _getopt_get_options { + my ($class, $params, $opt_spec) = @_; + my %options; + Getopt::Long::GetOptions(\%options, @$opt_spec); + return ( \%options, undef ); +} + +sub _getopt_spec_warnings { } + +sub _getopt_spec_exception { + my ($self, $warnings, $exception) = @_; + die @$warnings, $exception; +} + +sub _getopt_full_usage { + my ($self, $usage) = @_; + $usage->die; +} + sub _usage_format { return "usage: %c %o"; } @@ -136,7 +143,7 @@ sub _traditional_spec { foreach my $opt ( @{ $params{options} } ) { push @options, $opt->{opt_string}; - my $identifier = $opt->{name}; + 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}; @@ -215,14 +222,13 @@ sub _attrs_to_options { no Moose::Role; 1; -1; +__END__ =pod =head1 NAME -MooseX::Getopt::Basic - role to implement the basic functionality of -L without GLD. +MooseX::Getopt::Basic - role to implement the Getopt::Long functionality =head1 SYNOPSIS @@ -255,39 +261,9 @@ doesn't make use of L (or "GLD" for short). =head1 METHODS -=over 4 - -=item B - -See L . - -=item B - -This returns the role meta 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 AUTHOR - -Stevan Little Estevan@iinteractive.comE - -Brandon L. Black, Eblblack@gmail.comE - -Yuval Kogman, Enothingmuch@woobling.orgE - -=head1 CONTRIBUTORS - -Ryan D Johnson, Eryan@innerfence.comE - -Drew Taylor, Edrew@drewtaylor.comE +=head2 new_with_options -Shlomi Fish Eshlomif@cpan.orgE +See L. =head1 COPYRIGHT AND LICENSE diff --git a/lib/MooseX/Getopt/GLD.pm b/lib/MooseX/Getopt/GLD.pm index 806d738..819455d 100644 --- a/lib/MooseX/Getopt/GLD.pm +++ b/lib/MooseX/Getopt/GLD.pm @@ -1,25 +1,21 @@ -package MooseX::Getopt::GLD; +package MooseX::Getopt::GLD; use Moose::Role; -around '_getopt_spec' => sub { - my $orig = shift; - my $self = shift; +use Getopt::Long::Descriptive; - return $self->_gld_spec(@_); - # Ignore $orig, code for _gld_spec here -}; +with 'MooseX::Getopt::Basic'; -around '_get_options' => sub { - my $orig = shift; - my $class = shift; - - my ($params, $opt_spec) = @_; - return Getopt::Long::Descriptive::describe_options( - $class->_usage_format(%$params), @$opt_spec - ); +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 ) = @_; @@ -44,7 +40,7 @@ sub _gld_spec { }, ]; - my $identifier = $opt->{name}; + 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}; @@ -53,7 +49,7 @@ sub _gld_spec { return ( \@options, \%name_to_init_arg ); } -1; +no Moose::Role; 1; __END__ @@ -61,42 +57,37 @@ __END__ =head1 NAME -MooseX::Getopt::GLD - role to implement specific functionality for -L +MooseX::Getopt::GLD - A Moose role for processing command line options with Getopt::Long::Descriptive =head1 SYNOPSIS - -For internal use. -=head1 DESCRIPTION - -This is a role for C. - -=head1 METHODS + ## In your class + package My::App; + use Moose; -=over 4 + with 'MooseX::Getopt::GLD'; -=item meta + has 'out' => (is => 'rw', isa => 'Str', required => 1); + has 'in' => (is => 'rw', isa => 'Str', required => 1); -=back + # ... rest of the class here -=head1 BUGS + ## in your script + #!/usr/bin/perl -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 My::App; -=head1 AUTHOR + my $app = My::App->new_with_options(); + # ... rest of the script here -Dagfinn Ilmari MannsEker Eilmari@ilmari.orgE + ## on the command line + % perl my_app_script.pl -in file.input -out file.dump -Stevan Little Estevan@iinteractive.comE - -Yuval Kogman C<< >> +=head1 DESCRIPTION =head1 COPYRIGHT AND LICENSE -Copyright 2007-2008 by Infinity Interactive, Inc. +Copyright 2007-2009 by Infinity Interactive, Inc. L @@ -104,4 +95,3 @@ This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut -=head1