view release on metacpan or  search on metacpan

lib/Getopt/Complete/Args.pm  view on Meta::CPAN

    
    $self->_init();

    return $self;
}

sub options {
    shift->{options};
}

sub argv {
    @{ shift->{argv} };
}

sub errors {
    @{ shift->{errors} }
}

for my $method (qw/sub_commands option_names option_specs option_spec completion_handler/) {
    no strict 'refs';
    *{$method} = sub {
        my $self = shift;
        my $options = $self->options;
        return $options->$method(@_);
    }
}

sub has_value {
    my $self = shift;
    my $name = shift;
    return exists $self->{'values'}{$name};
}

sub value {
    my $self = shift;
    my $name = shift;
    my $value = $self->{'values'}{$name};
    return $value;
}

sub bare_args {
    my $self = shift;
    my $name = shift;
    my $value = $self->{'values'}{'<>'};
    return $value;
}

sub parent_sub_commands {
    my $self = shift;
    my $name = shift;
    my $value = $self->{'values'}{'>'};
    return $value;
}

sub _init {
    my $self = shift; 
    
    # as long as the first word is a valid sub-command, drill down to the subordinate options list,
    # and also shift the args into a special buffer
    # (if you have sub-commands AND bare arguments, and the arg is a valid sub-command ...don't do that
    local @ARGV = @{ $self->{argv} };
    my @sub_command_path;
    while (@ARGV and my $delegate = $self->options->completion_handler('>' . $ARGV[0])) {
        push @sub_command_path, shift @ARGV;
        $self->{options} = $delegate;
    }

    my %values;
    my @errors;

    do {
        local $SIG{__WARN__} = sub { push @errors, @_ };
        my $retval = Getopt::Long::GetOptions(\%values,$self->options->option_specs);
        if (!$retval and @errors == 0) {
            push @errors, "unknown error processing arguments!";
        }
        if ($ENV{COMP_CWORD}) {
            # we want to allow unknown option if the user puts them in, we just
            # didn't help complete it
            @errors = grep { $_ !~ /^Unknown option:/ } @errors;
        }
    };

    if (@ARGV) {
        if ($self->options->has_option('<>')) {
            my $a = $values{'<>'} ||= [];
            push @$a, @ARGV;
        }
        else {
            # in order to allow bare-args we only block unexpected arguments
            # for commands with sub-commands
            if ( $self->sub_commands ) {
                for my $arg (@ARGV) {
                    push @errors, "unexpected sub-command: $arg";
                }
            }
        }
    }

    if (@sub_command_path) {
        $values{'>'} = \@sub_command_path;
    }

    %{ $self->{'values'} } = %values;
    
    if (my @more_errors = $self->_validate_values()) {
        push @errors, @more_errors;
    }

    @{ $self->{'errors'} } = @errors;

    return (@errors ? () : 1);
}


sub _validate_values {
    my $self = shift;

    my @failed;
    for my $key (keys %{ $self->options->{completion_handlers} }) {
        my $completion_handler= $self->options->completion_handler($key);