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