lib/MooseX/Runnable/Util/ArgParser.pm

   1 package MooseX::Runnable::Util::ArgParser;
   2 use Moose;
   3 use MooseX::Types::Moose qw(HashRef ArrayRef Str Bool);
   4 use MooseX::Types::Path::Class qw(Dir);
   5 use List::MoreUtils qw(first_index);
   6
   7 use FindBin;
   8
   9 use namespace::autoclean -also => ['_look_for_dash_something', '_delete_first'];
  10
  11 has 'argv' => (
  12     is         => 'ro',
  13     isa        => ArrayRef,
  14     required   => 1,
  15     auto_deref => 1,
  16 );
  17
  18 has 'class_name' => (
  19     is         => 'ro',
  20     isa        => Str,
  21     lazy_build => 1,
  22 );
  23
  24 has 'modules' => (
  25     is         => 'ro',
  26     isa        => ArrayRef[Str],
  27     lazy_build => 1,
  28     auto_deref => 1,
  29 );
  30
  31 has 'include_paths' => (
  32     is         => 'ro',
  33     isa        => ArrayRef[Dir],
  34     lazy_build => 1,
  35     auto_deref => 1,
  36 );
  37
  38 has 'plugins' => (
  39     is         => 'ro',
  40     isa        => HashRef[ArrayRef[Str]],
  41     lazy_build => 1,
  42 );
  43
  44 has 'app_args' => (
  45     is         => 'ro',
  46     isa        => ArrayRef[Str],
  47     lazy_build => 1,
  48     auto_deref => 1,
  49 );
  50
  51 has 'is_help' => (
  52     is       => 'ro',
  53     isa      => Bool,
  54     lazy_build => 1,
  55 );
  56
  57
  58 sub _build_class_name {
  59     my $self = shift;
  60     my @args = $self->argv;
  61
  62     my $next_is_it = 0;
  63     my $need_dash_dash = 0;
  64
  65   ARG:
  66     for my $arg (@args) {
  67         if($next_is_it){
  68             return $arg;
  69         }
  70
  71         if($arg eq '--'){
  72             $next_is_it = 1;
  73             next ARG;
  74         }
  75
  76         next ARG if $arg =~ /^-[A-Za-z]/;
  77
  78         if($arg =~ /^[+]/){
  79             $need_dash_dash = 1;
  80             next ARG;
  81         }
  82
  83         return $arg unless $need_dash_dash;
  84     }
  85
  86     if($next_is_it){
  87         confess 'Parse error: expecting ClassName, got EOF';
  88     }
  89     if($need_dash_dash){
  90         confess 'Parse error: expecting --, got EOF';
  91     }
  92
  93     confess "Parse error: looking for ClassName, but can't find it; perhaps you meant '--help' ?";
  94 }
  95
  96 sub _look_for_dash_something($@) {
  97     my ($something, @args) = @_;
  98     my @result;
  99
 100     my $rx = qr/^-$something(.*)$/;
 101   ARG:
 102     for my $arg (@args) {
 103         last ARG if $arg eq '--';
 104         last ARG unless $arg =~ /^-/;
 105         if($arg =~ /$rx/){
 106             push @result, $1;
 107         }
 108     }
 109
 110     return @result;
 111 }
 112
 113 sub _build_modules {
 114     my $self = shift;
 115     my @args = $self->argv;
 116     return [ _look_for_dash_something 'M', @args ];
 117 }
 118
 119 sub _build_include_paths {
 120     my $self = shift;
 121     my @args = $self->argv;
 122     return [ map { Path::Class::dir($_) } _look_for_dash_something 'I', @args ];
 123 }
 124
 125 sub _build_is_help {
 126     my $self = shift;
 127     my @args = $self->argv;
 128     return
 129       (_look_for_dash_something 'h', @args) ||
 130       (_look_for_dash_something '\\?', @args) ||
 131       (_look_for_dash_something '-help', @args) ;;
 132 }
 133
 134 sub _build_plugins {
 135     my $self = shift;
 136     my @args = $self->argv;
 137     $self->class_name; # causes death when plugin syntax is wrong
 138
 139     my %plugins;
 140     my @accumulator;
 141     my $in_plugin = undef;
 142
 143   ARG:
 144     for my $arg (@args) {
 145         if(defined $in_plugin){
 146             if($arg eq '--'){
 147                 $plugins{$in_plugin} = [@accumulator];
 148                 @accumulator = ();
 149                 return \%plugins;
 150             }
 151             elsif($arg =~ /^[+](.+)$/){
 152                 $plugins{$in_plugin} = [@accumulator];
 153                 @accumulator = ();
 154                 $in_plugin = $1;
 155                 next ARG;
 156             }
 157             else {
 158                 push @accumulator, $arg;
 159             }
 160         }
 161         else { # once we are $in_plugin, we can never be out again
 162             if($arg eq '--'){
 163                 return {};
 164             }
 165             elsif($arg =~ /^[+](.+)$/){
 166                 $in_plugin = $1;
 167                 next ARG;
 168             }
 169         }
 170     }
 171
 172     if($in_plugin){
 173         confess "Parse error: expecting arguments for plugin $in_plugin, but got EOF. ".
 174           "Perhaps you forgot '--' ?";
 175     }
 176
 177     return {};
 178 }
 179
 180 sub _delete_first($\@) {
 181     my ($to_delete, $list) = @_;
 182     my $idx = first_index { $_ eq $to_delete } @$list;
 183     splice @$list, $idx, 1;
 184     return;
 185 }
 186
 187 # this is a dumb way to do it, but i forgot about it until just now,
 188 # and don't want to rewrite the whole class ;) ;)
 189 sub _build_app_args {
 190     my $self = shift;
 191     my @args = $self->argv;
 192
 193     return [] if $self->is_help; # LIES!!11!, but who cares
 194
 195     # functional programmers may wish to avert their eyes
 196     _delete_first $_, @args for map { "-M$_" } $self->modules;
 197     _delete_first $_, @args for map { "-I$_" } $self->include_paths;
 198
 199     my %plugins = %{ $self->plugins };
 200
 201   PLUGIN:
 202     for my $p (keys %plugins){
 203         my $vl = scalar @{ $plugins{$p} };
 204         my $idx = first_index { $_ eq "+$p" } @args;
 205         next PLUGIN if $idx == -1; # HORRIBLE API!
 206
 207         splice @args, $idx, $vl + 1;
 208     }
 209
 210     if($args[0] eq '--'){
 211         shift @args;
 212     }
 213
 214     if($args[0] eq $self->class_name){
 215         shift @args;
 216     }
 217     else {
 218         confess 'Parse error: Some residual crud was found before the app name: '.
 219           join ', ', @args;
 220     }
 221
 222     return [@args];
 223 }
 224
 225 # XXX: bad
 226 sub guess_cmdline {
 227     my ($self, %opts) = @_;
 228
 229     confess 'Parser is help' if $self->is_help;
 230
 231     my @perl_flags = @{$opts{perl_flags} || []};
 232     my @without_plugins = @{$opts{without_plugins} || []};
 233
 234     # invoke mx-run
 235     my @cmdline = ($^X, @perl_flags, $FindBin::Bin.'/'.$FindBin::Script);
 236     push @cmdline, map { "-I$_" } $self->include_paths;
 237     push @cmdline, map { "-M$_" } $self->modules;
 238
 239   p:
 240     for my $plugin (keys %{$self->plugins}){
 241         for my $without (@without_plugins) {
 242             next p if $without eq $plugin;
 243         }
 244         push @cmdline, "+$plugin", @{$self->plugins->{$plugin} || []};
 245     }
 246     push @cmdline, '--';
 247     push @cmdline, $self->class_name;
 248     push @cmdline, $self->app_args;
 249
 250     return @cmdline;
 251 }
 252
 253 1;
 254
 255 __END__
 256
 257 =head1 NAME
 258
 259 MooseX::Runnable::Util::ArgParser - parse @ARGV for mx-run
 260
 261 =head1 SYNOPSIS
 262
 263     my $parser = MooseX::Runnable::Util::ArgParser->new(
 264         argv => \@ARGV,
 265     );
 266
 267     $parser->class_name;
 268     $parser->modules;
 269     $parser->include_paths;
 270     $parser->plugins;
 271     $parser->is_help;
 272     $parser->app_args;
 273