From: Tomas Doran <bobtfish@bobtfish.net>
Date: Sun, 30 Aug 2009 16:19:49 +0000 (+0100)
Subject: Merge master into branch
X-Git-Tag: 0.22~4
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMooseX-Getopt.git;a=commitdiff_plain;h=refs%2Fheads%2Ftopic%2Fsplit_gld_from_basic

Merge master into branch
---

5ab6d553547e6ae66794d819b37b8f9320c6c17f
diff --cc ChangeLog
index a23201b,7b0018b..6d48eec
--- a/ChangeLog
+++ b/ChangeLog
@@@ -1,13 -1,14 +1,19 @@@
  Revision history for Perl extension MooseX-Getopt
  
-   * MooseX::Getopt
-     - Enable and document the argv parameter to the constructor.
++0.22
 +  * MooseX::Getopt
 +    - Split into MooseX::Getopt::Basic (without the G::L::Descriptive support)
 +    and MooseX::Getopt::GLD.
 +
+ 0.21 Thu. Aug 27 2009
+   * MooseX::Getopt
+     - Enable and document the argv parameter to the constructor.
+     - Applied patches in RT43200 and RT43255
+     - Applied patch from RT#47766 to not die if SimpleConfig cannot find the
+       default config file name.
+ 
  0.20 Wed. July 9 2009
- 	~ fix MANIFEST.SKIP to avoid double-packaging
+ 	- fix MANIFEST.SKIP to avoid double-packaging
  
  0.19 Wed. July 8 2009
    * MooseX::Getopt
diff --cc lib/MooseX/Getopt/Basic.pm
index 88fa48b,0000000..453b913
mode 100644,000000..100644
--- a/lib/MooseX/Getopt/Basic.pm
+++ b/lib/MooseX/Getopt/Basic.pm
@@@ -1,292 -1,0 +1,297 @@@
 +package MooseX::Getopt::Basic;
 +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
 +
 +our $VERSION   = '0.20';
 +our $AUTHORITY = 'cpan:STEVAN';
 +
 +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) = @_;
 +
 +    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(defined $configfile) {
-             $config_from_file = $class->get_config_from_file($configfile);
++        if (defined $configfile) {
++            $config_from_file = eval {
++                $class->get_config_from_file($configfile);
++            };
++            if ($@) {
++                die $@ unless $@ =~ /Specified configfile '\Q$configfile\E' does not exist/;
++            }
 +        }
 +    }
 +
 +    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}) )
 +    {
 +        $processed{usage}->die();
 +    }
 +
 +    $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 ) = $class->_getopt_spec(%params);
 +
 +    # Get a clean copy of the original @ARGV
 +    my $argv_copy = [ @ARGV ];
 +
 +    my @err;
 +
 +    my ( $parsed_options, $usage ) = eval {
 +        local $SIG{__WARN__} = sub { push @err, @_ };
 +
 +        return $class->_get_options(\%params, $opt_spec);
 +    };
 +
 +    die join "", grep { defined } @err, $@ if @err or $@;
 +
 +    # 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 _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 = $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;
 +}
 +
 +no Moose::Role; 1;
 +
 +1;
 +
 +=pod
 +
 +=head1 NAME
 +
 +MooseX::Getopt::Basic - role to implement the basic functionality of
 +L<MooseX::Getopt> without GLD.
 +
 +=head1 SYNOPSIS
 +
 +  ## In your class
 +  package My::App;
 +  use Moose;
 +
 +  with 'MooseX::Getopt::Basic';
 +
 +  has 'out' => (is => 'rw', isa => 'Str', required => 1);
 +  has 'in'  => (is => 'rw', isa => 'Str', required => 1);
 +
 +  # ... rest of the class here
 +
 +  ## in your script
 +  #!/usr/bin/perl
 +
 +  use My::App;
 +
 +  my $app = My::App->new_with_options();
 +  # ... rest of the script here
 +
 +  ## on the command line
 +  % perl my_app_script.pl --in file.input --out file.dump
 +
 +=head1 DESCRIPTION
 +
 +This is like L<MooseX::Getopt> and can be used instead except that it
 +doesn't make use of L<Getopt::Long::Descriptive> (or "GLD" for short).
 +
 +=head1 METHODS
 +
 +=over 4
 +
 +=item B<new_with_options>
 +
 +See L<MooseX::Getopt> .
 +
 +=item B<meta>
 +
 +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 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>
 +
 +Drew Taylor, E<lt>drew@drewtaylor.comE<gt>
 +
 +Shlomi Fish E<lt>shlomif@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
 +