lib/MooseX/Runnable/Util/ArgParser.pm

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