File Coverage

blib/lib/Getopt/Kingpin.pm

Criterion	Covered	Total	%
statement	207	207	100.0
branch	104	104	100.0
condition	15	15	100.0
subroutine	20	20	100.0
pod	8	8	100.0
total	354	354	100.0

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;

our $VERSION = "0.09";

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;
    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 ($dummy, $exit) = $self->args->get_by_index($arg_index)->set_value($arg);
                    if (defined $exit) {
                        return undef, $exit;
                    }
                    if (not $self->args->get_by_index($arg_index)->is_cumulative) {
                        $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;
    }

    foreach my $f ($self->flags->values) {
        if (defined $f->value) {
            next;
        } elsif (defined $f->_envar) {
            my ($dummy, $exit) = $f->set_value($f->_envar);
            if (defined $exit) {
                return undef, $exit;
            }
        } elsif (defined $f->_default) {
            if ($f->type =~ /List$/) {
                foreach my $default (@{$f->_default}) {
                    my ($dummy, $exit) = $f->set_value($default);
                    if (defined $exit) {
                        return undef, $exit;
                    }
                }
            } else {
                my ($dummy, $exit) = $f->set_value($f->_default);
                if (defined $exit) {
                    return undef, $exit;
                }
            }
        } elsif ($f->type =~ /List$/) {
            $f->value([]);
        }
    }
    for (my $i = 0; $i < $self->args->count; $i++) {
        my $arg = $self->args->get_by_index($i);
        if (defined $arg->value) {
            next;
        } elsif (defined $arg->_envar) {
            my ($dummy, $exit) = $arg->set_value($arg->_envar);
            if (defined $exit) {
                return undef, $exit;
            }
        } elsif (defined $arg->_default) {
            if ($arg->type =~ /List$/) {
                foreach my $default (@{$arg->_default}) {
                    my ($dummy, $exit) = $arg->set_value($default);
                    if (defined $exit) {
                        return undef, $exit;
                    }
                }
            } else {
                my ($dummy, $exit) = $arg->set_value($arg->_default);
                if (defined $exit) {
                    return undef, $exit;
                }
            }
        } elsif ($arg->type =~ /List$/) {
            $arg->value([]);
        }
    }

    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__