lib/MooseX/Getopt/Basic.pm

   1
   2 package MooseX::Getopt::Basic;
   3 use Moose::Role;
   4
   5 use MooseX::Getopt::OptionTypeMap;
   6 use MooseX::Getopt::Meta::Attribute;
   7 use MooseX::Getopt::Meta::Attribute::NoGetopt;
   8 use Carp ();
   9
  10 use Getopt::Long ();
  11
  12 our $VERSION = '0.25';
  13
  14 has ARGV       => (is => 'rw', isa => 'ArrayRef', metaclass => "NoGetopt");
  15 has extra_argv => (is => 'rw', isa => 'ArrayRef', metaclass => "NoGetopt");
  16
  17 sub new_with_options {
  18     my ($class, @params) = @_;
  19
  20     my $config_from_file;
  21     if($class->meta->does_role('MooseX::ConfigFromFile')) {
  22         local @ARGV = @ARGV;
  23
  24         my $configfile;
  25         my $opt_parser = Getopt::Long::Parser->new( config => [ qw( pass_through ) ] );
  26         $opt_parser->getoptions( "configfile=s" => \$configfile );
  27
  28         if(!defined $configfile) {
  29             my $cfmeta = $class->meta->find_attribute_by_name('configfile');
  30             $configfile = $cfmeta->default if $cfmeta->has_default;
  31             if (ref $configfile eq 'CODE') {
  32                 # not sure theres a lot you can do with the class and may break some assumptions
  33                 # warn?
  34                 $configfile = &$configfile($class);
  35             }
  36             if (defined $configfile) {
  37                 $config_from_file = eval {
  38                     $class->get_config_from_file($configfile);
  39                 };
  40                 if ($@) {
  41                     die $@ unless $@ =~ /Specified configfile '\Q$configfile\E' does not exist/;
  42                 }
  43             }
  44         }
  45         else {
  46             $config_from_file = $class->get_config_from_file($configfile);
  47         }
  48     }
  49
  50     my $constructor_params = ( @params == 1 ? $params[0] : {@params} );
  51
  52     Carp::croak("Single parameters to new_with_options() must be a HASH ref")
  53         unless ref($constructor_params) eq 'HASH';
  54
  55     my %processed = $class->_parse_argv(
  56         options => [
  57             $class->_attrs_to_options( $config_from_file )
  58         ],
  59         params => $constructor_params,
  60     );
  61
  62     my $params = $config_from_file ? { %$config_from_file, %{$processed{params}} } : $processed{params};
  63
  64     # did the user request usage information?
  65     if ( $processed{usage} && ($params->{'?'} or $params->{help} or $params->{usage}) )
  66     {
  67         $class->_getopt_full_usage($processed{usage});
  68     }
  69
  70     $class->new(
  71         ARGV       => $processed{argv_copy},
  72         extra_argv => $processed{argv},
  73         %$constructor_params, # explicit params to ->new
  74         %$params, # params from CLI
  75     );
  76 }
  77
  78 sub _getopt_spec { shift->_traditional_spec(@_); }
  79
  80 sub _parse_argv {
  81     my ( $class, %params ) = @_;
  82
  83     local @ARGV = @{ $params{params}{argv} || \@ARGV };
  84
  85     my ( $opt_spec, $name_to_init_arg ) = $class->_getopt_spec(%params);
  86
  87     # Get a clean copy of the original @ARGV
  88     my $argv_copy = [ @ARGV ];
  89
  90     my @warnings;
  91     my ( $parsed_options, $usage ) = eval {
  92         local $SIG{__WARN__} = sub { push @warnings, @_ };
  93
  94         return $class->_getopt_get_options(\%params, $opt_spec);
  95     };
  96
  97     $class->_getopt_spec_warnings(@warnings) if @warnings;
  98     $class->_getopt_spec_exception(\@warnings, $@) if $@;
  99
 100     # Get a copy of the Getopt::Long-mangled @ARGV
 101     my $argv_mangled = [ @ARGV ];
 102
 103     my %constructor_args = (
 104         map {
 105             $name_to_init_arg->{$_} => $parsed_options->{$_}
 106         } keys %$parsed_options,
 107     );
 108
 109     return (
 110         params    => \%constructor_args,
 111         argv_copy => $argv_copy,
 112         argv      => $argv_mangled,
 113         ( defined($usage) ? ( usage => $usage ) : () ),
 114     );
 115 }
 116
 117 sub _getopt_get_options {
 118     my ($class, $params, $opt_spec) = @_;
 119     my %options;
 120     Getopt::Long::GetOptions(\%options, @$opt_spec);
 121     return ( \%options, undef );
 122 }
 123
 124 sub _getopt_spec_warnings { }
 125
 126 sub _getopt_spec_exception {
 127     my ($self, $warnings, $exception) = @_;
 128     die @$warnings, $exception;
 129 }
 130
 131 sub _getopt_full_usage {
 132     my ($self, $usage) = @_;
 133     $usage->die;
 134 }
 135
 136 sub _usage_format {
 137     return "usage: %c %o";
 138 }
 139
 140 sub _traditional_spec {
 141     my ( $class, %params ) = @_;
 142
 143     my ( @options, %name_to_init_arg, %options );
 144
 145     foreach my $opt ( @{ $params{options} } ) {
 146         push @options, $opt->{opt_string};
 147
 148         my $identifier = lc($opt->{name});
 149         $identifier =~ s/\W/_/g; # Getopt::Long does this to all option names
 150
 151         $name_to_init_arg{$identifier} = $opt->{init_arg};
 152     }
 153
 154     return ( \@options, \%name_to_init_arg );
 155 }
 156
 157 sub _compute_getopt_attrs {
 158     my $class = shift;
 159     grep {
 160         $_->does("MooseX::Getopt::Meta::Attribute::Trait")
 161             or
 162         $_->name !~ /^_/
 163     } grep {
 164         !$_->does('MooseX::Getopt::Meta::Attribute::Trait::NoGetopt')
 165     } $class->meta->get_all_attributes
 166 }
 167
 168 sub _get_cmd_flags_for_attr {
 169     my ( $class, $attr ) = @_;
 170
 171     my $flag = $attr->name;
 172
 173     my @aliases;
 174
 175     if ($attr->does('MooseX::Getopt::Meta::Attribute::Trait')) {
 176         $flag = $attr->cmd_flag if $attr->has_cmd_flag;
 177         @aliases = @{ $attr->cmd_aliases } if $attr->has_cmd_aliases;
 178     }
 179
 180     return ( $flag, @aliases );
 181 }
 182
 183 sub _attrs_to_options {
 184     my $class = shift;
 185     my $config_from_file = shift || {};
 186
 187     my @options;
 188
 189     foreach my $attr ($class->_compute_getopt_attrs) {
 190         my ( $flag, @aliases ) = $class->_get_cmd_flags_for_attr($attr);
 191
 192         my $opt_string = join(q{|}, $flag, @aliases);
 193
 194         if ($attr->name eq 'configfile') {
 195             $opt_string .= '=s';
 196         }
 197         elsif ($attr->has_type_constraint) {
 198             my $type = $attr->type_constraint;
 199             if (MooseX::Getopt::OptionTypeMap->has_option_type($type)) {
 200                 $opt_string .= MooseX::Getopt::OptionTypeMap->get_option_type($type)
 201             }
 202         }
 203
 204         push @options, {
 205             name       => $flag,
 206             init_arg   => $attr->init_arg,
 207             opt_string => $opt_string,
 208             required   => $attr->is_required && !$attr->has_default && !$attr->has_builder && !exists $config_from_file->{$attr->name},
 209             # NOTE:
 210             # this "feature" was breaking because
 211             # Getopt::Long::Descriptive would return
 212             # the default value as if it was a command
 213             # line flag, which would then override the
 214             # one passed into a constructor.
 215             # See 100_gld_default_bug.t for an example
 216             # - SL
 217             #( ( $attr->has_default && ( $attr->is_default_a_coderef xor $attr->is_lazy ) ) ? ( default => $attr->default({}) ) : () ),
 218             ( $attr->has_documentation ? ( doc => $attr->documentation ) : () ),
 219         }
 220     }
 221
 222     return @options;
 223 }
 224
 225 no Moose::Role; 1;
 226
 227 __END__
 228
 229 =pod
 230
 231 =head1 NAME
 232
 233 MooseX::Getopt::Basic - role to implement the Getopt::Long functionality
 234
 235 =head1 SYNOPSIS
 236
 237   ## In your class
 238   package My::App;
 239   use Moose;
 240
 241   with 'MooseX::Getopt::Basic';
 242
 243   has 'out' => (is => 'rw', isa => 'Str', required => 1);
 244   has 'in'  => (is => 'rw', isa => 'Str', required => 1);
 245
 246   # ... rest of the class here
 247
 248   ## in your script
 249   #!/usr/bin/perl
 250
 251   use My::App;
 252
 253   my $app = My::App->new_with_options();
 254   # ... rest of the script here
 255
 256   ## on the command line
 257   % perl my_app_script.pl --in file.input --out file.dump
 258
 259 =head1 DESCRIPTION
 260
 261 This is like L<MooseX::Getopt> and can be used instead except that it
 262 doesn't make use of L<Getopt::Long::Descriptive> (or "GLD" for short).
 263
 264 =head1 METHODS
 265
 266 =head2 new_with_options
 267
 268 See L<MooseX::Getopt/new_with_options>.
 269
 270 =head1 COPYRIGHT AND LICENSE
 271
 272 Copyright 2007-2008 by Infinity Interactive, Inc.
 273
 274 L<http://www.iinteractive.com>
 275
 276 This library is free software; you can redistribute it and/or modify
 277 it under the same terms as Perl itself.
 278
 279 =cut
 280