X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMooseX%2FGetopt%2FBasic.pm;h=e2d27404d7ddc2697539bb7715d10f2940d216e3;hb=60321fa1aa5b3c94e62c54b70e8c74e3b7e675b0;hp=453b913cbb9537882f8fcd511c4cf52d6bf527b8;hpb=5ab6d553547e6ae66794d819b37b8f9320c6c17f;p=gitmo%2FMooseX-Getopt.git

diff --git a/lib/MooseX/Getopt/Basic.pm b/lib/MooseX/Getopt/Basic.pm
index 453b913..e2d2740 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,13 @@ use MooseX::Getopt::Meta::Attribute;
 use MooseX::Getopt::Meta::Attribute::NoGetopt;
 use Carp ();
 
-use Getopt::Long (); # GLD uses it anyway, doesn't hurt
+use Getopt::Long ();
 
-our $VERSION   = '0.20';
-our $AUTHORITY = 'cpan:STEVAN';
+our $VERSION = '0.25';
 
 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,20 +28,27 @@ 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} );
-    
+
     Carp::croak("Single parameters to new_with_options() must be a HASH ref")
         unless ref($constructor_params) eq 'HASH';
 
@@ -71,7 +64,7 @@ sub new_with_options {
     # did the user request usage information?
     if ( $processed{usage} && ($params->{'?'} or $params->{help} or $params->{usage}) )
     {
-        $processed{usage}->die();
+        $class->_getopt_full_usage($processed{usage});
     }
 
     $class->new(
@@ -82,6 +75,8 @@ sub new_with_options {
     );
 }
 
+sub _getopt_spec { shift->_traditional_spec(@_); }
+
 sub _parse_argv {
     my ( $class, %params ) = @_;
 
@@ -92,15 +87,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 ];
@@ -119,6 +114,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";
 }
@@ -131,7 +145,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};
@@ -210,14 +224,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<MooseX::Getopt> without GLD.
+MooseX::Getopt::Basic - role to implement the Getopt::Long functionality
 
 =head1 SYNOPSIS
 
@@ -250,39 +263,9 @@ 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>
+=head2 new_with_options
 
-Shlomi Fish E<lt>shlomif@cpan.orgE<gt>
+See L<MooseX::Getopt/new_with_options>.
 
 =head1 COPYRIGHT AND LICENSE