view release on metacpan or  search on metacpan

lib/CLI/Osprey/Role.pm  view on Meta::CPAN

  while (defined( my $arg = shift @ARGV )) {
    # As soon as we find a -- or a non-option word, stop processing and leave everything
    # from there onwards in ARGV as either positional args or a subcommand.
    if ($arg eq '--' or $arg eq '-' or $arg !~ /^-/) {
      push @new_argv, $arg, @ARGV;
      last;
    }

    my ($arg_name_with_dash, $arg_value) = split /=/, $arg, 2;
    unshift @ARGV, $arg_value if defined $arg_value;

    my ($dash, $negative, $arg_name_without_dash)
      = $arg_name_with_dash =~ /^(-+)(no\-)?(.+)$/;

    my $option_name;
    
    if ($dash eq '--') {
      my $option_names = $abbreviations->{$arg_name_without_dash};
      if (defined $option_names) {
        if (@$option_names == 1) {
          $option_name = $option_names->[0];
        } else {
          # TODO: can't we produce a warning saying that it's ambiguous and which options conflict?
          $option_name = undef;
        }
      }
    }

    my $arg_name = ($dash || '') . ($negative || '');
    if (defined $option_name) {
      $arg_name .= $option_name;
    } else {
      $arg_name .= $arg_name_without_dash;
    }

    push @new_argv, $arg_name;
    if (defined $option_name && $options->{$option_name}{format}) {
      push @new_argv, shift @ARGV;
    }
  }

  return @new_argv;
}

use Moo::Role;

requires qw(_osprey_config _osprey_options _osprey_subcommands);

has 'parent_command' => (
  is => 'ro',
);

has 'invoked_as' => (
  is => 'ro',
);

sub new_with_options {
  my ($class, %params) = @_;
  my %config = $class->_osprey_config;

  local @ARGV = @ARGV if $config{protect_argv};

  if (!defined $params{invoked_as}) {
    $params{invoked_as} = Getopt::Long::Descriptive::prog_name();
  }

  my ($parsed_params, $usage) = $class->parse_options(%params);

  if ($parsed_params->{h}) {
    return $class->osprey_usage(1, $usage);
  } elsif ($parsed_params->{help}) {
    return $class->osprey_help(1, $usage);
  } elsif ($parsed_params->{man}) {
    return $class->osprey_man($usage);
  }

  my %merged_params;
  if ($config{prefer_commandline}) {
    %merged_params = (%params, %$parsed_params);
  } else {
    %merged_params = (%$parsed_params, %params);
  }

  my %subcommands = $class->_osprey_subcommands;
  my ($subcommand_name, $subcommand_class);
  if (@ARGV && $ARGV[0] ne '--') { # Check what to do with remaining options
    if ($ARGV[0] =~ /^--/) { # Getopt stopped at an unrecognized option, error.
      print STDERR "Unknown option '$ARGV[0]'.\n";
      return $class->osprey_usage(1, $usage);
    } elsif (%subcommands) {
      $subcommand_name = shift @ARGV; # Remove it so the subcommand sees only options
      $subcommand_class = $subcommands{$subcommand_name};
      if (!defined $subcommand_class) {
        print STDERR "Unknown subcommand '$subcommand_name'.\n";
        return $class->osprey_usage(1, $usage);
      }
    }
    # If we're not expecting a subcommand, and getopt didn't stop at an option, consider the remainder
    # as positional args and leave them in ARGV.
  }

  my $self;
  unless (eval { $self = $class->new(%merged_params); 1 }) {
    if ($@ =~ /^Attribute \((.*?)\) is required/) {
      print STDERR "$1 is missing\n";
    } elsif ($@ =~ /^Missing required arguments: (.*) at /) {
      my @missing_required = split /,\s/, $1;
      print STDERR "$_ is missing\n" for @missing_required;
    } elsif ($@ =~ /^(.*?) required/) {
      print STDERR "$1 is missing\n";
    } elsif ($@ =~ /^isa check .*?failed: /) {
      print STDERR substr($@, index($@, ':') + 2);
    } else {
      print STDERR $@;
    }
    return $class->osprey_usage(1, $usage);
  }

  return $self unless $subcommand_class;

  use_module($subcommand_class) unless ref $subcommand_class;