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.10";
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, "[<flags>]";
if ($self->commands->count > 1) {
push @help, "<command>";
my $has_args = 0;
foreach my $cmd ($self->commands->get_all) {
if ($cmd->args->count > 0) {
$has_args = 1;
}
}
push @help, "[<args> ...]";
} 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__
=encoding utf-8
=head1 NAME
Getopt::Kingpin - command line options parser (like golang kingpin)
=head1 SYNOPSIS
use Getopt::Kingpin;
my $kingpin = Getopt::Kingpin->new;
$kingpin->flags->get("help")->short('h');
my $verbose = $kingpin->flag('verbose', 'Verbose mode.')->short('v')->bool;
my $name = $kingpin->arg('name', 'Name of user.')->required->string;
$kingpin->parse;
# perl sample.pl hello
printf "name : %s\n", $name;
Automatically generate --help option.
usage: script.pl [<flags>] <name>
Flags:
-h, --help Show context-sensitive help.
-v, --verbose Verbose mode.
Args:
<name> Name of user.
Support sub-command.
use Getopt::Kingpin;
my $kingpin = Getopt::Kingpin->new;
my $register = $kingpin->command('register', 'Register a new user.');
my $register_nick = $register->arg('nick', 'Nickname for user.')->required->string;
my $register_name = $register->arg('name', 'Name for user.')->required->string;
my $post = $kingpin->command('post', 'Post a message to a channel.');
my $post_image = $post->flag('image', 'Image to post.')->file;
my $post_channel = $post->arg('channel', 'Channel to post to.')->required->string;
my $post_text = $post->arg('text', 'Text to post.')->string_list;
my $cmd = $kingpin->parse;
if ($cmd eq 'register') {
printf "register %s %s\n", $register_nick, $register_name;
} elsif ($cmd eq 'post') {
printf "post %s %s %s\n", $post_image, $post_channel, @{$post_text->value};
} else {
$kingpin->help;
}
Help is below.
usage: script.pl [<flags>] <command> [<args> ...]
Flags:
--help Show context-sensitive help.
Commands:
help [<command>...]
Show help.
register [<nick>] [<name>]
Register a new user.
post [<flags>] [<channel>] [<text>]
Post a message to a channel.
=head1 DESCRIPTION
Getopt::Kingpin is a command line parser.
It supports flags and positional arguments.
=over
=item *
Simple to use
=item *
Automatically generate help flag (--help).
=back
This module is inspired by Kingpin written in golang.
https://github.com/alecthomas/kingpin
=head1 METHOD
=head2 new()
Create a parser object.
Default script-name is basename($0).
my $kingpin = Getopt::Kingpin->new;
my $kingpin = Getopt::Kingpin->new("script-name.pl", "description of script");
my $kingpin = Getopt::Kingpin->new(
name => "script-name.pl",
description => "description of script",
);
# Use hash ref to set description only.
my $kingpin = Getopt::Kingpin->new({
description => "description of script",
});
=head2 flag($name, $description)
Add and return Getopt::Kingpin::Flag object.
# Define --debug option
my $debug = $kingpin->flag("debug", "Enable debug mode.");
# Set $debug to boolean value
$debug->bool;
# shorthand
my $debug = $kingpin->flag("debug", "Enable debug mode.")->bool;
Getopt::Kingpin::Flag object has methods below.
=head3 value()
Get flag value.
my $name = $kingpin->flag("name", "Set name.")->string;
# perl script.pl --name 'kingpin'
printf "%s\n", $name->value; # -> kingpin
# simple way
printf "%s\n", $name; # -> kingpin
=head3 short()
Set short flag.
# Define --debug and -d
my $debug = $kingpin->flag("debug", "Enable debug mode.")->short('-d')->bool;
=head3 default()
The default value can be overridden with the default($value).
# Set default value to true (1)
my $debug = $kingpin->flag("debug", "Enable debug mode.")->default(1)->bool;
The default can be set to a coderef or object overloading &{}.
my $debug = $kingpin->flag("debug", "Enable debug mode.")->default(sub {
my $config = read_config_files();
return $config->{DEBUG};
})->bool;
=head3 override_default_from_envar()
The default value can be overridden with the override_default_from_envar($envar).
# Set default value to environment value of __DEBUG__
# export $__DEBUG__=1 to enable debug mode
my $debug = $kingpin->flag("debug", "Enable debug mode.")->override_default_from_envar("__DEBUG__")->bool;
=head3 required()
Set required.
my $debug = $kingpin->flag("debug", "Enable debug mode.")->required->bool;
=head3 placeholder()
Set placeholder value for flag in the help.
Here are some examples of flags with various permutations.
--name=NAME # flag("name")->string
--name="Harry" # flag("name")->default("Harry")->string
--name=FULL-NAME # flag("name")->placeholder("FULL-NAME")->string
=head3 hidden()
If set hidden(), flag does not appear in the help.
=head3 types
=head4 bool()
Boolean value. (0 or 1)
Boolean flag has a negative complement: --<name> and --no-<name>.
# --debug or --no-debug
my $debug = $kingpin->flag("debug")->bool;
=head4 existing_dir()
Path::Tiny object.
=head4 existing_file()
Path::Tiny object.
=head4 existing_file_or_dir()
Path::Tiny object.
=head4 file()
Path::Tiny object.
=head4 int()
Integer value.
=head4 num()
Numeric value.
=head4 string()
String value.
It is default type to flag.
=head4 string_list(), int_list(), file_list(), etc
Allows repeated uses of a flag.
--input=customers.csv --input=customers2.csv
=head4 string_hash(), int_hash(), file_hash(), etc
Allows repeated use of a flag as key-value pairs.
--define os=linux --define arch=x86_64
=head2 arg($name, $description)
Add and return Getopt::Kingpin::Arg object.
my $name = $kingpin->arg("name", "Set name")->string;
Getopt::Kingpin::Arg object has methods below.
Below are same as Flag's.
=head3 value()
Get value.
=head3 default()
Set default value.
=head3 override_default_from_envar()
Set default value by environment variable.
=head3 required()
Set required.
=head2 command()
Add sub-command.
my $post = $kingpin->command("post", "post image");
=head2 parse()
Parse @arguments.
If @arguments is empty, parse @ARGV.
# parse @ARGV
$kingpin->parse;
# parse @arguments
$kingpin->parse(@arguments);
If define sub-command, parse() return Getopt::Kingpin::Command object;
my $kingpin = Getopt::Kingpin->new();
my $post = $kingpin->command("post", "post image");
my $server = $post->arg("server", "")->string();
my $image = $post->arg("image", "")->file();
my $cmd = $kingpin->parse;
printf "cmd : %s\n", $cmd;
printf "cmd : %s\n", $cmd->name;
You may also pass an arrayref to parse():
$kingpin->parse( \@arguments );
An empty arrayref will not cause Kingpin to parse @ARGV like
an empty array would.
=head2 _parse()
Parse @_. Internal use only.
=head2 version($version)
Set application version to $version.
=head2 help_short()
Internal use only.
=head2 help()
Print help.
=head1 SEE ALSO
=over
=item *
L<Getopt::Long>
=item *
L<Getopt::Long::Descriptive>
=item *
L<Smart::Options>
=item *
L<MooseX::Getopt::Usage>
=back
=head1 LICENSE
Copyright (C) sago35.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=head1 AUTHOR
sago35 E<lt>sago35@gmail.comE<gt>
=cut