File Coverage

blib/lib/Getopt/Long/Subcommand.pm

Criterion	Covered	Total	%
statement	84	141	59.5
branch	32	68	47.0
condition	15	28	53.5
subroutine	9	12	75.0
pod	1	1	100.0
total	141	250	56.4

package Getopt::Long::Subcommand;

our $DATE = '2017-08-12'; # DATE
our $VERSION = '0.102'; # VERSION

use 5.010001;
use strict;
use warnings;
#use Log::ger;

require Exporter;
our @ISA = qw(Exporter);
## no critic (Modules::ProhibitAutomaticExportation)
our @EXPORT = qw(
                    GetOptions
            );
## use critic

# XXX completion & configure are actually only allowed at the top-level
my @known_cmdspec_keys = qw(
    options
    subcommands
    default_subcommand
    summary description
    completion
    configure
);

sub _cmdspec_opts_to_gl_ospec {
    my ($cmdspec_opts, $is_completion, $res) = @_;
    return { map {
        if ($is_completion) {
            # we don't want side-effects during completion (handler printing or
            # existing, etc), so we set an empty coderef for all handlers.
            ($_ => sub{});
        } else {
            my $k = $_;
            my $v = $cmdspec_opts->{$k};
            my $handler = ref($v) eq 'HASH' ? $v->{handler} : $v;
            if (ref($handler) eq 'CODE') {
                my $orig_handler = $handler;
                $handler = sub {
                    my ($cb, $val) = @_;
                    $orig_handler->($cb, $val, $res);
                };
            }
            ($k => $handler);
        }
    } keys %$cmdspec_opts };
}

sub _gl_getoptions {
    require Getopt::Long;

    my ($ospec, $configure, $pass_through, $res) = @_;

    my @configure = @{
        $configure //
            ['no_ignore_case', 'no_getopt_compat', 'gnu_compat', 'bundling']
        };
    if ($pass_through) {
        push @configure, 'pass_through'
            unless grep { $_ eq 'pass_through' } @configure;
    } else {
        @configure = grep { $_ ne 'pass_through' } @configure;
    }
    #log_trace('[comp][glsubc] Performing Getopt::Long::GetOptions (configure: %s)',
    #          $pass_through, \@configure);

    my $old_conf = Getopt::Long::Configure(@configure);
    local $SIG{__WARN__} = sub {} if $pass_through;

    # ugh, this is ugly. the problem we're trying to solve: in the case of 'subc
    # --help', 'subc' is consumed first by Getopt::Long and thus removed from
    # @ARGV. when --help handler wants to find out the subcommand name ('subc'),
    # it doesn't have anywhere to look for. so we give it in $res which is
    # passed as the third argument to the handler.
    local $res->{_non_options_argv} = [];

    #log_trace('[comp][glsubc] @ARGV before Getopt::Long::GetOptions: %s', \@ARGV);
    #log_trace('[comp][glsubc] spec for Getopt::Long::GetOptions: %s', $ospec);
    my $gl_res = Getopt::Long::GetOptions(
        %$ospec,
        '<>' => sub { push @{ $res->{_non_options_argv} }, $_[0] },
    );
    @ARGV = @{ $res->{_non_options_argv} };

    #log_trace('[comp][glsubc] @ARGV after Getopt::Long::GetOptions: %s', \@ARGV);
    Getopt::Long::Configure($old_conf);
    $gl_res;
}

sub _GetOptions {
    my ($cmdspec, $is_completion, $res, $stash) = @_;

    $res //= {success=>undef};
    $stash //= {
        path => '', # for displaying error message
        level => 0,
    };

    # check command spec
    {
        #log_trace("[comp][glsubc] Checking cmdspec keys: %s", [keys %$cmdspec]);
        for my $k (keys %$cmdspec) {
            (grep { $_ eq $k } @known_cmdspec_keys)
                or die "Unknown command specification key '$k'" .
                    ($stash->{path} ? " (under $stash->{path})" : "") . "\n";
        }
    }

    my $has_subcommands = $cmdspec->{subcommands} &&
        keys(%{$cmdspec->{subcommands}});
    #log_trace("TMP:has_subcommands=%s", $has_subcommands);
    my $pass_through = $has_subcommands || $is_completion;

    my $ospec = _cmdspec_opts_to_gl_ospec(
        $cmdspec->{options}, $is_completion, $res);
    unless (_gl_getoptions(
        $ospec, $cmdspec->{configure}, $pass_through, $res)) {
        $res->{success} = 0;
        return $res;
    }

    # for doing completion
    if ($is_completion) {
        $res->{comp_ospec} //= {};
        for (keys %$ospec) {
            $res->{comp_ospec}{$_} = $ospec->{$_};
        }
    }

    if ($has_subcommands) {
        # for doing completion of subcommand names
        if ($is_completion) {
            $res->{comp_subcommand_names}[$stash->{level}] =
                [sort keys %{$cmdspec->{subcommands}}];
        }

        $res->{subcommand} //= [];

        my $push;
        my $sc_name;

        if (defined $res->{subcommand}[ $stash->{level} ]) {
            # subcommand has been set, e.g. by option handler
            $sc_name = $res->{subcommand}[ $stash->{level} ];
        } elsif (@ARGV) {
            $sc_name = shift @ARGV;
            $push++; # we need to push to $res->{subcommand} later
        } elsif (defined $cmdspec->{default_subcommand}) {
            $sc_name = $cmdspec->{default_subcommand};
            $push++;
        } else {
            # no subcommand
            $res->{success} = 1;
            return $res;
        }

        # for doing completion of subcommand names
        if ($is_completion) {
            push @{ $res->{comp_subcommand_name} }, $sc_name;
        }

        my $sc_spec = $cmdspec->{subcommands}{$sc_name};
        unless ($sc_spec) {
            warn "Unknown subcommand '$sc_name'".
                ($stash->{path} ? " for $stash->{path}":"")."\n"
                    unless $is_completion;
            $res->{success} = 0;
            return $res;
        };
        push @{ $res->{subcommand} }, $sc_name if $push;
        local $stash->{path} = ($stash->{path} ? "/" : "") . $sc_name;
        local $stash->{level} = $stash->{level}+1;
        _GetOptions($sc_spec, $is_completion, $res, $stash);
    }
    $res->{success} //= 1;

    #log_trace('[comp][glsubc] Final @ARGV: %s', \@ARGV) unless $stash->{path};
    #log_trace('[comp][glsubc] TMP: stash=%s', $stash);
    #log_trace('[comp][glsubc] TMP: res=%s', $res);
    $res;
}

sub GetOptions {
    my %cmdspec = @_;

    # figure out if we run in completion mode
    my ($is_completion, $shell, $words, $cword);
  CHECK_COMPLETION:
    {
        if ($ENV{COMP_SHELL}) {
            ($shell = $ENV{COMP_SHELL}) =~ s!.+/!!;
        } elsif ($ENV{COMMAND_LINE}) {
            $shell = 'tcsh';
        } else {
            $shell = 'bash';
        }

        if ($ENV{COMP_LINE} || $ENV{COMMAND_LINE}) {
            if ($ENV{COMP_LINE}) {
                $is_completion++;
                require Complete::Bash;
                ($words, $cword) = @{ Complete::Bash::parse_cmdline(
                    undef, undef, {truncate_current_word=>1}) };
                ($words, $cword) = @{ Complete::Bash::join_wordbreak_words(
                    $words, $cword) };
            } elsif ($ENV{COMMAND_LINE}) {
                $is_completion++;
                require Complete::Tcsh;
                $shell = 'tcsh';
                ($words, $cword) = @{ Complete::Tcsh::parse_cmdline() };
            } else {
                last CHECK_COMPLETION;
            }

            shift @$words; $cword--; # strip program name
            @ARGV = @$words;
        }
    }

    my $res = _GetOptions(\%cmdspec, $is_completion);

    if ($is_completion) {
        my $ospec = $res->{comp_ospec};
        require Complete::Getopt::Long;
        my $compres = Complete::Getopt::Long::complete_cli_arg(
            words => $words, cword => $cword, getopt_spec=>$ospec,
            extras => {
                stash => $res->{stash},
            },
            bundling => do {
                if (!$cmdspec{configure}) {
                    1;
                } elsif (grep { $_ eq 'bundling' } @{ $cmdspec{configure} }) {
                    1;
                } elsif (grep { $_ eq 'no_bundling' } @{ $cmdspec{configure} }) {
                    0;
                } else {
                    0;
                }
            },
            completion => sub {
                my %args = @_;

                my $word  = $args{word} // '';
                my $type  = $args{type};
                my $stash = $args{stash};

                # complete subcommand names
                if ($type eq 'arg' &&
                        $args{argpos} < @{$res->{comp_subcommand_names}//[]}) {
                    require Complete::Util;
                    return Complete::Util::complete_array_elem(
                        array => $res->{comp_subcommand_names}[$args{argpos}],
                        word  => $res->{comp_subcommand_name}[$args{argpos}],
                    );
                }

                $args{getopt_res} = $res;
                $args{subcommand} = $res->{comp_subcommand_name};
                $cmdspec{completion}->(%args) if $cmdspec{completion};
            },
        );

        if ($shell eq 'bash') {
            print Complete::Bash::format_completion($compres);
        } elsif ($shell eq 'tcsh') {
            print Complete::Tcsh::format_completion($compres);
        } else {
            die "Unknown shell '$shell'";
        }

        exit 0;
    }

    # cleanup unneeded details
    $res;
}

1;
# ABSTRACT: Process command-line options, with subcommands and completion

__END__