File Coverage

blib/lib/Getopt/Kingpin.pm

Criterion	Covered	Total	%
statement	215	215	100.0
branch	102	102	100.0
condition	29	30	96.6
subroutine	22	22	100.0
pod	8	8	100.0
total	376	377	99.7

package Getopt::Kingpin;
use 5.008001;
use strict;
use warnings;
use Object::Simple -base;
use Getopt::Kingpin::Flags;
use Getopt::Kingpin::Args;
use Getopt::Kingpin::Commands;
use File::Basename;
use Carp;
use Scalar::Util qw(blessed);

our $VERSION = "0.11";

use overload (
    '""' => sub {$_[0]->name},
    fallback => 1,
);

has flags => sub {
    my $flags = Getopt::Kingpin::Flags->new;
    $flags->add(
        name        => 'help',
        description => 'Show context-sensitive help.',
    )->bool();
    return $flags;
};

has args => sub {
    my $args = Getopt::Kingpin::Args->new;
    return $args;
};

has commands => sub {
    my $commands = Getopt::Kingpin::Commands->new;
    return $commands;
};

has _version => sub {
    return "";
};

has parent => sub {
    return
};

has name => sub {
    return basename($0);
};

has description => sub {
    return "";
};

has terminate => sub {
    return sub {
        my $ret = defined $_[1] ? $_[1] : 0;
        exit $ret;
    };
};

sub new {
    my $class = shift;
    my @args = @_;

    my $self;
    if (@args == 2) {
        $self = $class->SUPER::new(
            name => $args[0],
            description => $args[1],
        );
    } else {
        $self = $class->SUPER::new(@args);
    }

    return $self;
}

sub flag {
    my $self = shift;
    my ($name, $description) = @_;
    my $ret = $self->flags->add(
        name        => $name,
        description => $description,
    );
    return $ret;
}

sub arg {
    my $self = shift;
    my ($name, $description) = @_;
    my $ret = $self->args->add(
        name        => $name,
        description => $description,
    );
    return $ret;
}

sub command {
    my $self = shift;
    my ($name, $description) = @_;
    if ($self->commands->count == 0) {
        $self->commands->add(
            name => "help",
            description => "Show help.",
        );
    }
    my $ret = $self->commands->add(
        name        => $name,
        description => $description,
        parent      => $self,
    );
    return $ret;
}

sub parse {
    my $self = shift;
    my @argv = @_;

    if (scalar @argv == 0) {
        @argv = @ARGV;
    }

    my ($ret, $exit_code) = $self->_parse(@argv);
    if (defined $exit_code) {
        return $self->terminate->($ret, $exit_code);
    }
    return $ret;
}

sub _parse {
    my $self = shift;
    my @argv = @_;

    if (defined $self->parent) {
        $self->flags->unshift($self->parent->flags->values);
    }

    my $required_but_not_found = {
        map {$_->name => $_} grep {$_->_required} $self->flags->values,
    };
    my $arg_index = 0;
    my $arg_only = 0;

    if (@argv == 1 and ref($argv[0]) and ref($argv[0]) eq "ARRAY") {
        @argv = @{ $argv[0] };
    }

    while (scalar @argv > 0) {
        my $arg = shift @argv;
        if ($arg eq "--") {
            $arg_only = 1;
        } elsif ($arg_only == 0 and $arg =~ /^--(no-)?(\S+?)(=(\S+))?$/) {
            my $no    = $1;
            my $name  = $2;
            my $equal = $3;
            my $val   = $4;

            delete $required_but_not_found->{$name} if exists $required_but_not_found->{$name};
            my $v = $self->flags->get($name);

            if (not defined $v) {
                printf STDERR "%s: error: unknown long flag '--%s', try --help\n", $self->name, $name;
                return undef, 1;
            }

            my $value;
            if ($v->type eq "Bool") {
                $value = defined $no ? 0 : 1;
            } elsif (defined $equal) {
                $value = $val;
            } else {
                $value = shift @argv;
            }

            my ($dummy, $exit) = $v->set_value($value);
            if (defined $exit) {
                return undef, $exit;
            }
        } elsif ($arg_only == 0 and $arg =~ /^-(\S+)$/) {
            my $short_name = $1;
            while (length $short_name > 0) {
                my ($s, $remain) = split //, $short_name, 2;
                my $name;
                foreach my $f ($self->flags->values) {
                    if (defined $f->short_name and $f->short_name eq $s) {
                        $name = $f->name;
                    }
                }
                if (not defined $name) {
                    printf STDERR "%s: error: unknown short flag '-%s', try --help\n", $self->name, $s;
                    return undef, 1;
                }
                delete $required_but_not_found->{$name} if exists $required_but_not_found->{$name};
                my $v = $self->flags->get($name);

                my $value;
                if ($v->type eq "Bool") {
                    $value = 1;
                } else {
                    if (length $remain > 0) {
                        $value = $remain;
                        $remain = "";
                    } else {
                        $value = shift @argv;
                    }
                }

                my ($dummy, $exit) = $v->set_value($value);
                if (defined $exit) {
                    return undef, $exit;
                }
                $short_name = $remain;
            }
        } else {
            if ($arg_index == 0) {
                my $cmd = $self->commands->get($arg);
                if (defined $cmd) {
                    if ($cmd->name eq "help") {
                        $self->flags->get("help")->set_value(1)
                    } else {
                        my @argv_for_command = @argv;
                        @argv = ();

                        if ($self->flags->get("help")) {
                            push @argv_for_command, "--help";
                        }
                        return $cmd->_parse(@argv_for_command);
                    }
                }
            }

            if (not ($arg_index == 0 and $arg eq "help")) {
                if ($arg_index < $self->args->count) {
                    my $arg_obj = $self->args->get_by_index($arg_index);
                    my ($dummy, $exit) = $arg_obj->set_value($arg);
                    if (defined $exit) {
                        return undef, $exit;
                    }
                    if (not $arg_obj->is_cumulative || $arg_obj->is_hash) {
                        $arg_index++;
                    }
                } else {
                    printf STDERR "%s: error: unexpected %s, try --help\n", $self->name, $arg;
                    return undef, 1;
                }
            }
        }
    }

    if ($self->flags->get("help")) {
        $self->help;
        return undef, 0;
    }

    if ($self->flags->get("version")) {
        printf STDERR "%s\n", $self->_version;
        return undef, 0;
    }

    my $process_item = sub {
        my $item = shift;
        if (defined $item->value) {
            return;
        } elsif (defined $item->_envar) {
            my ($dummy, $exit) = $item->set_value($item->_envar);
            if (defined $exit) {
                return undef, $exit;
            }
        } elsif (defined $item->_default) {
            my $default = $item->_default;
            if (ref($default) eq 'CODE'
            || (blessed($default) && overload::Method($default, '&{}'))) {
                $default = $default->();
            }
            if ($item->type =~ /List$/) {
                foreach my $val (@{$default}) {
                    my ($dummy, $exit) = $item->set_value($val);
                    if (defined $exit) {
                        return undef, $exit;
                    }
                }
            } elsif ($item->type =~ /Hash$/) {
                while (my ($key, $val) = each %{$default}) {
                    my ($dummy, $exit) = $item->set_value([ $key, $val ]);
                    if (defined $exit) {
                        return undef, $exit;
                    }
                }
            } else {
                my ($dummy, $exit) = $item->set_value($default);
                if (defined $exit) {
                    return undef, $exit;
                }
            }
        } elsif ($item->type =~ /List$/) {
            $item->value([]);
        } elsif ($item->type =~ /Hash$/) {
            $item->value({});
        }
        return;
    };

    foreach my $f ($self->flags->values) {
        my @r = $process_item->($f);
        return @r if @r > 1;
    }
    for (my $i = 0; $i < $self->args->count; $i++) {
        my $arg = $self->args->get_by_index($i);
        my @r = $process_item->($arg);
        return @r if @r > 1;
    }

    foreach my $r (values %$required_but_not_found) {
        printf STDERR "%s: error: required flag --%s not provided, try --help\n", $self->name, $r->name;
        return undef, 1;
    }
    for (my $i = 0; $i < $self->args->count; $i++) {
        my $arg = $self->args->get_by_index($i);
        if ($arg->_required and not $arg->_defined) {
            printf STDERR "%s: error: required arg '%s' not provided, try --help\n", $self->name, $arg->name;
            return undef, 1;
        }
    }

    return $self;
}

sub version {
    my $self = shift;
    my ($version) = @_;

    my $f = $self->flags->add(
        name        => 'version',
        description => 'Show application version.',
    )->bool();
    $self->_version($version);
}

sub help_short {
    my $self = shift;
    my @help = ($self->name);

    push @help, "[]";

    if ($self->commands->count > 1) {
        push @help, "";

        my $has_args = 0;
        foreach my $cmd ($self->commands->get_all) {
            if ($cmd->args->count > 0) {
                $has_args = 1;
            }
        }

        push @help, "[ ...]";
    } else {
        foreach my $arg ($self->args->get_all) {
            push @help, sprintf "<%s>", $arg->name;
        }
    }

    return join " ", @help;
}

sub help {
    my $self = shift;
    printf "usage: %s\n", $self->help_short;
    printf "\n";

    if ($self->description ne "") {
        printf "%s\n", $self->description;
        printf "\n";
    }

    printf "%s\n", $self->flags->help;

    if ($self->commands->count > 1) {
        printf "%s\n", $self->commands->help;
    } else {
        if ($self->args->count > 0) {
            printf "%s\n", $self->args->help;
        }
    }
}


1;
__END__