File Coverage

blib/lib/Getopt/Compact/WithCmd.pm

Criterion	Covered	Total	%
statement	473	490	96.5
branch	226	252	89.6
condition	91	119	76.4
subroutine	44	49	89.8
pod	16	16	100.0
total	850	926	91.7

package Getopt::Compact::WithCmd;

use strict;
use warnings;
use 5.008_001;
use Data::Dumper ();
use List::Util qw(max);
use Getopt::Long qw(GetOptionsFromArray);
use Carp ();
use constant DEFAULT_CONFIG => (
    no_auto_abbrev => 1,
    no_ignore_case => 1,
    bundling       => 1,
);

our $VERSION = '0.22';

my $TYPE_MAP = {
    'Bool'   => '!',
    'Incr'   => '+',
    'Str'    => '=s',
    'Int'    => '=i',
    'Num'    => '=f',
    'ExNum'  => '=o',
};

my $TYPE_GEN = {};

sub new {
    my ($class, %args) = @_;
    my $self = bless {
        cmd         => $args{cmd} || do { require File::Basename; File::Basename::basename($0) },
        name        => $args{name},
        version     => $args{version} || $::VERSION,
        modes       => $args{modes},
        opt         => {},
        usage       => exists $args{usage} && !$args{usage} ? 0 : 1,
        args        => $args{args} || '',
        _argv       => \@ARGV,
        struct      => [],
        summary     => {},
        requires    => {},
        ret         => 0,
        error       => undef,
        other_usage => undef,
        commands    => [],
        _struct     => $args{command_struct} || {},
    }, $class;

    my %config = (DEFAULT_CONFIG, %{$args{configure} || {}});
    my @gconf = grep $config{$_}, keys %config;
    Getopt::Long::Configure(@gconf) if @gconf;

    $self->_init_summary($args{command_struct});

    $self->_init_struct($args{global_struct} || []);
    my $opthash = $self->_parse_struct || return $self;
    if ($args{command_struct}) {
        if (my @gopts = $self->_parse_argv) {
            $self->{ret} = $self->_parse_option(\@gopts, $opthash);
            unshift @ARGV, @gopts;
            return $self unless $self->{ret};
            return $self if $self->_want_help;
        }
        $self->_check_requires;
    }
    else {
        $self->{ret} = $self->_parse_option(\@ARGV, $opthash);
        return $self unless $self->{ret};
        return $self if $self->_want_help;
        $self->_check_requires;
        return $self;
    }

    $self->_parse_command_struct($args{command_struct});
    return $self;
}

sub new_from_array {
    my ($class, $args, %options) = @_;
    unless (ref $args eq 'ARRAY') {
        Carp::croak("Usage: $class->new_from_array(\\\@args, %options)");
    }
    local *ARGV = $args;
    return $class->new(%options);
}

sub new_from_string {
    my ($class, $str, %options) = @_;
    unless (defined $str) {
        Carp::croak("Usage: $class->new_from_string(\$str, %options)");
    }
    require Text::ParseWords;
    my $args = [Text::ParseWords::shellwords($str)];
    local *ARGV = $args;
    return $class->new(%options);
}

sub args       { $_[0]->{_argv}     }
sub error      { $_[0]->{error}||'' }
sub command    { $_[0]->{command}   }
sub commands   { $_[0]->{commands}  }
sub status     { $_[0]->{ret}       }
sub is_success { $_[0]->{ret}       }
sub pod2usage  { Carp::carp('Not implemented') }

sub opts {
    my($self) = @_;
    my $opt = $self->{opt};
    if ($self->{usage} && ($opt->{help} || $self->status == 0)) {
        # display usage message & exit
        print $self->usage;
        exit !$self->status;
    }
    return $opt;
}

sub usage {
    my($self, @targets) = @_;
    my $usage = '';
    my(@help, @commands);

    if ((defined $self->command && $self->command eq 'help') || @targets) {
        delete $self->{command};
        @targets = @{$self->{_argv}} unless @targets;
        for (my $i = 0; $i < @targets; $i++) {
            my $target = $targets[$i];
            last unless defined $target;
            unless (ref $self->{_struct}{$target} eq 'HASH') {
                $self->{error} = "Unknown command: $target";
                last;
            }
            else {
                $self->{command} = $target;
                push @{$self->{commands}}, $target;
                $self->_init_struct($self->{_struct}{$target}{options});
                $self->_extends_usage($self->{_struct}{$target});

                if (ref $self->{_struct}{$target}{command_struct} eq 'HASH') {
                    $self->{_struct} = $self->{_struct}{$target}{command_struct};
                }
                else {
                    $self->{summary} = {};
                }
            }
        }
    }

    my($name, $version, $cmd, $struct, $args, $summary, $error, $other_usage) = map
        $self->{$_} || '', qw/name version cmd struct args summary error other_usage/;

    $usage .= "$error\n" if $error;

    if ($name) {
        $usage .= $name;
        $usage .= " v$version" if $version;
        $usage .= "\n";
    }

    if ($self->command && $self->command ne 'help') {
        my $sub_command = join q{ }, @{$self->commands} ? @{$self->commands} : $self->command;
        $usage .= "usage: $cmd $sub_command [options]";
    }
    else {
        $usage .= "usage: $cmd [options]";
        $usage .= ' COMMAND' if keys %$summary;
    }
    $usage .= ($args ? " $args" : '') . "\n\n";

    for my $o (@$struct) {
        my ($name_spec, $desc, $arg_spec, $dist, $opts) = @$o;
        $desc = '' unless defined $desc;
        my @onames = $self->_option_names($name_spec);
        my $optname = join
            (', ', map { (length($_) > 1 ? '--' : '-').$_ } @onames);
        $optname = '    '.$optname unless length($onames[0]) == 1;
        my $info = do {
            local $Data::Dumper::Indent = 0;
            local $Data::Dumper::Terse  = 1;
            my $info = [];
            push @$info, $self->_opt_spec2name($arg_spec) || $arg_spec || '';
            push @$info, $opts->{required}        ? "(required)" : '';
            push @$info, defined $opts->{default} ? "(default: ".Data::Dumper::Dumper($opts->{default}).")" : '';
            $info;
        };
        push @help, [ $optname, $info, ucfirst($desc) ];
    }

    if (@help) {
        require Text::Table;
        my $sep = \'   ';
        $usage .= "options:\n";
        $usage .= Text::Table->new($sep, '', $sep, '', $sep, '')->load($self->_format_info(@help))->stringify."\n";
    }

    if (defined $other_usage && length $other_usage > 0) {
        $other_usage =~ s/\n$//ms;
        $usage .= "$other_usage\n\n";
    }

    if (!$self->command || $self->{has_sub_command}) {
        for my $command (sort keys %$summary) {
            push @commands, [ $command, ucfirst $summary->{$command} ];
        }

        if (@commands) {
            require Text::Table;
            my $sep = \'   ';
            $usage .= "Implemented commands are:\n";
            $usage .= Text::Table->new($sep, '', $sep, '')->load(@commands)->stringify."\n";
            my $help_command = "$cmd help COMMAND";
            if (@{$self->commands}) {
                my $sub_commands = join q{ }, @{$self->commands};
                $help_command = "$cmd $sub_commands COMMAND --help";
            }
            $usage .= "See '$help_command' for more information on a specific command.\n\n";
        }
    }

    return $usage;
}

sub show_usage {
    my $self = shift;
    print $self->usage(@_);
    exit !$self->status;
}

sub completion {
    my($self, $shell) = @_;
    $shell ||= 'bash';

    if ($shell eq 'bash') {
        return $self->_completion_bash;
    } else {
        Carp::carp("Not implemented: completion for $shell");
        return "";
    }
}

sub show_completion {
    my $self = shift;
    print $self->completion(@_);
    exit !$self->status;
}

sub _completion_bash {
    my $self = shift;
    my $comp = '';

    my $prog  = $self->{name} || substr($0, rindex($0, '/')+1);
    my $fname = $prog;
    $fname =~ s/[.-]/_/g;

    my @global_opts;
    my @commands;
    my $case = {
        word  => '"$cmd"',
        cases => [],
    };

    @global_opts = $self->_options2optarg($self->{struct});

    for my $cmd (sort keys %{ $self->{_struct} }) {
        my $s = $self->{_struct}{$cmd};

        my @opts = $self->_options2optarg($s->{options});
        my @commands2;

        if (ref $s->{command_struct} eq 'HASH') {
            for my $cmd (sort keys %{ $s->{command_struct} }) {
                my $s = $s->{command_struct}{$cmd};
                my @opts = $self->_options2optarg($s->{options});

                push @commands2, {
                    cmd  => $cmd,
                    opts => \@opts,
                };
            }
        }

        push @commands, {
            cmd    => $cmd,
            opts   => \@opts,
            subcmd => \@commands2,
            args   => ($s->{args} || ''),
        };
    }

    $comp .= "_$fname() {\n";
    $comp .= <<'EOC';
  COMPREPLY=()
  local cur=${COMP_WORDS[COMP_CWORD]}
  local prev=${COMP_WORDS[COMP_CWORD-1]}
  local cmd=()
  for ((i=1; i
    # skip global opts and type to find cmd
    if [[ "${COMP_WORDS[$i]}" != -* && "${COMP_WORDS[$i]}" != [A-Z]* ]]; then
      cmd[${#cmd[@]}]=${COMP_WORDS[$i]}
    fi
  done

EOC

    $comp .= sprintf qq{  local global_opts="%s"\n},
        join(" ", map { @{$_->{opt}} } @global_opts);
    $comp .= sprintf qq{  local cmds="%s"\n},
        join(" ", map { $_->{cmd} } @commands);
    $comp .= "\n";

    ### sub commands
    for my $command (@commands) {

        my $case_prev = {
            word  => '"$prev"',
            cases => [
                _opts2casecmd(@{ $command->{opts} }),
                {
                    pat => '*',
                    cmd => ['COMPREPLY=($(compgen -W "'._gen_wordlist($command).'" -- "$cur"))'],
                },
            ],
        };

        if (scalar(@{ $command->{subcmd} }) > 0) {
            my @cases;

            for my $subcommand (@{ $command->{subcmd} }) {
                next if (scalar(@{ $subcommand->{opts} }) <= 0);
                push @cases, {
                    pat => $subcommand->{cmd},
                    cmd => [{
                        word  => '"$prev"',
                        cases => [
                            _opts2casecmd(@{ $subcommand->{opts} }),
                            {
                                pat => '*',
                                cmd => ['COMPREPLY=($(compgen -W "'._gen_wordlist($subcommand).'" -- "$cur"))'],
                            },
                        ],
                    }],
                };
            }

            push @cases, {
                pat => '*',
                cmd => [ $case_prev ],
            };

            push @{ $case->{cases} }, {
                pat => $command->{cmd},
                cmd => [{
                    word  => '"${cmd[1]}"',
                    cases => [@cases],
                }],
            };
        } else {
            push @{ $case->{cases} }, {
                pat => $command->{cmd},
                cmd => [ $case_prev ],
            };
        }
    }

    ### global opts
    push @{ $case->{cases} }, {
        pat => '*',
        cmd => [{
            word  => '"$prev"',
            cases => [
                _opts2casecmd(@global_opts),
                {
                    pat => '*',
                    cmd => ['COMPREPLY=($(compgen -W "$global_opts $cmds" -- "$cur"))'],
                },
            ],
        }],
    };

    my @c = _generate_case_command($case);
    $comp .= join("\n", map {"  ".$_} @c)."\n";

    $comp .= <<"EOC";
}

complete -F _$fname $prog
EOC
    return $comp;
}

# take following hashref and generate case command string
# +{
#     word  => WORD, # case WORD in
#     cases => [
#         {
#             pat => PATTERN,               # PATTERN)
#             cmd => ['cmd1', 'cmd2', ...], # COMMANDS;;
#         },
#         {
#             pat => PATTERN,               # PATTERN)
#             cmd => [                      # nested case command
#                 {
#                     word  => WORD,
#                     cases => [ ... ],
#                 },
#             ],
#         },
#     ],
# }
sub _generate_case_command {
    my $case = shift;
    my @line;

    push @line, "case $case->{word} in";
    for my $c (@{ $case->{cases} }) {
        push @line, "  $c->{pat})";
        for my $cmd (@{ $c->{cmd} }, ';;') {
            if (ref $cmd eq 'HASH') {
                push @line, map {"    ".$_} _generate_case_command->($cmd);
            } else {
                push @line, "    ".$cmd;
            }
        }
    }
    push @line, "esac";

    return @line;
}

sub _options2optarg {
    my($self, $opts) = @_;
    my @optarg;

    for my $o (@{ $opts }) {
        my ($name_spec, $desc, $arg_spec, $dist, $opts) = @$o;
        my @onames = map { (length($_) > 1 ? '--' : '-').$_ } $self->_option_names($name_spec);
        my $arg = $self->_opt_spec2name($arg_spec) || $arg_spec || '';
        $arg = '' if $arg eq 'Incr';
        push @optarg, {
            opt => \@onames,
            arg => $arg,
        };
    }

    return @optarg;
}

sub _opts2casecmd {
    my @cases;
    for my $o (grep { $_->{arg} } @_) {
        push @cases, {
            pat => join("|", @{ $o->{opt} }),
            cmd => ['COMPREPLY=($(compgen -W "'.$o->{arg}.'" -- "$cur"))'],
        };
    }

    return @cases;
}

sub _gen_wordlist {
    my $command = shift;

    return join(" ",
                '-h', '--help',
                (map { @{$_->{opt}} } @{ $command->{opts} }),
                ($command->{args}||''),
                (map { $_->{cmd} } @{ $command->{subcmd} }),
            );
}

sub _opt_spec2name {
    my ($self, $spec) = @_;
    my $name = '';
    return $name unless defined $spec;
    my ($type, $dest) = $spec =~ /^[=:]?([!+isof])([@%])?/;
    if ($type) {
        $name =
            $type eq '!' ? 'Bool'  :
            $type eq '+' ? 'Incr'  :
            $type eq 's' ? 'Str'   :
            $type eq 'i' ? 'Int'   :
            $type eq 'f' ? 'Num'   :
            $type eq 'o' ? 'ExNum' : '';
    }
    if ($dest) {
        $name = $dest eq '@' ? "Array[$name]" : $dest eq '%' ? "Hash[$name]" : $name;
    }
    return $name;
}

sub _format_info {
    my ($self, @help) = @_;

    my $type_max     = 0;
    my $required_max = 0;
    my $default_max  = 0;
    for my $row (@help) {
        my ($type, $required, $default) = @{$row->[1]};
        $type_max     = max $type_max, length($type);
        $required_max = max $required_max, length($required);
        $default_max  = max $default_max, length($default);
    }

    for my $row (@help) {
        my ($type, $required, $default) = @{$row->[1]};
        my $parts = [];
        for my $stuff ([$type_max, $type], [$required_max, $required], [$default_max, $default]) {
            push @$parts, sprintf '%-*s', @$stuff if $stuff->[0] > 0;
        }
        $row->[1] = join ' ', @$parts;
    }

    return @help;
}

sub _parse_command_struct {
    my ($self, $command_struct) = @_;
    $command_struct ||= {};

    my $command_map = { map { $_ => 1 } keys %$command_struct };
    my $command = shift @ARGV;
    unless (defined $command) {
        $self->{ret} = $self->_check_requires;
        return $self;
    }

    unless ($command_map->{help}) {
        $command_map->{help} = 1;
        $command_struct->{help} = {
            args => '[COMMAND]',
            desc => 'show help message',
        };
    }

    unless (exists $command_map->{$command}) {
        $self->{error} = "Unknown command: $command";
        $self->{ret} = 0;
        return $self;
    }

    $self->{command} ||= $command;

    if ($command eq 'help') {
        $self->{ret} = 0;
        delete $self->{error};
        if (defined $ARGV[0] && exists $command_struct->{$ARGV[0]}) {
            my $nested_struct = $command_struct->{$ARGV[0]}{command_struct};
            $self->_init_nested_struct($nested_struct) if $nested_struct;
        }
        return $self;
    }

    push @{$self->{commands} ||= []}, $command;
    $self->_init_struct($command_struct->{$command}{options});
    $self->_extends_usage($command_struct->{$command});
    my $opthash = $self->_parse_struct || return $self;

    if (my $nested_struct = $command_struct->{$command}{command_struct}) {
        $self->_init_nested_struct($nested_struct);

        my @opts = $self->_parse_argv($nested_struct);
        $self->{ret} = $self->_parse_option(\@opts, $opthash);
        unshift @ARGV, @opts;
        $self->_check_requires;
        if ($self->_want_help) {
            delete $self->{error};
            $self->{ret} = 0;
        }
        return $self unless $self->{ret};
        $self->_parse_command_struct($nested_struct);
    }
    else {
        $self->{ret} = $self->_parse_option(\@ARGV, $opthash);
        $self->_check_requires;
        $self->{has_sub_command} = 0;
        if ($self->_want_help) {
            delete $self->{error};
            $self->{ret} = 0;
        }
    }

    return $self;
}

sub _want_help {
    exists $_[0]->{opt}{help} && $_[0]->{opt}{help} ? 1 : 0;
}

sub _init_nested_struct {
    my ($self, $nested_struct) = @_;
    $self->{summary} = {}; # reset
    $self->_init_summary($nested_struct);
    $self->{has_sub_command} = 1;
}

sub _parse_option {
    my ($self, $argv, $opthash) = @_;
    local $SIG{__WARN__} = sub {
        $self->{error} = join '', @_;
        chomp $self->{error};
    };
    my $ret = GetOptionsFromArray($argv, %$opthash) ? 1 : 0;

    $self->{parsed_opthash} = $opthash;

    return $ret;
}

sub _parse_argv {
    my ($self, $struct) = @_;
    $struct ||= $self->{_struct};

    my @opts;
    while (@ARGV) {
        my $argv = shift @ARGV;
        push @opts, $argv;
        last if exists $struct->{$argv};
    }
    return @opts;
}

sub _parse_struct {
    my ($self) = @_;
    my $struct = $self->{struct};

    my $opthash = {};
    my $default_opthash = {};
    my $default_args = [];
    for my $s (@$struct) {
        my($m, $descr, $spec, $ref, $opts) = @$s;
        my @onames = $self->_option_names($m);
        my($longname) = grep length($_) > 1, @onames;
        my ($type, $cb) = $self->_compile_spec($spec);
        my $o = join('|', @onames).($type||'');
        my $dest = $longname ? $longname : $onames[0];
        $opts ||= {};
        my $destination;
        if (ref $cb eq 'CODE') {
            my $t =
                substr($type, -1, 1) eq '@' ? 'Array' :
                substr($type, -1, 1) eq '%' ? 'Hash'  : '';
            if (ref $ref eq 'CODE') {
                $destination = sub { $ref->($_[0], $cb->($_[1])) };
            }
            elsif (ref $ref) {
                if (ref $ref eq 'SCALAR' || ref $ref eq 'REF') {
                    $$ref = $t eq 'Array' ? [] : $t eq 'Hash' ? {} : undef;
                }
                elsif (ref $ref eq 'ARRAY') {
                    @$ref = ();
                }
                elsif (ref $ref eq 'HASH') {
                    %$ref = ();
                }
                $destination = sub {
                    if ($t eq 'Array') {
                        if (ref $ref eq 'SCALAR' || ref $ref eq 'REF') {
                            push @{$$ref}, scalar $cb->($_[1]);
                        }
                        elsif (ref $ref eq 'ARRAY') {
                            push @$ref, scalar $cb->($_[1]);
                        }
                        elsif (ref $ref eq 'HASH') {
                            my @kv = split '=', $_[1], 2;
                            die qq(Option $_[0], key "$_[1]", requires a value\n)
                                unless @kv == 2;
                            $ref->{$kv[0]} = scalar $cb->($kv[1]);
                        }
                    }
                    elsif ($t eq 'Hash') {
                        if (ref $ref eq 'SCALAR' || ref $ref eq 'REF') {
                            $$ref->{$_[1]} = scalar $cb->($_[2]);
                        }
                        elsif (ref $ref eq 'ARRAY') {
                            # XXX but Getopt::Long is $ret = join '=', $_[1], $_[2];
                            push @$ref, $_[1], scalar $cb->($_[2]);
                        }
                        elsif (ref $ref eq 'HASH') {
                            $ref->{$_[1]} = scalar $cb->($_[2]);
                        }
                    }
                    else {
                        if (ref $ref eq 'SCALAR' || ref $ref eq 'REF') {
                            $$ref = $cb->($_[1]);
                        }
                        elsif (ref $ref eq 'ARRAY') {
                            @$ref = (scalar $cb->($_[1]));
                        }
                        elsif (ref $ref eq 'HASH') {
                            my @kv = split '=', $_[1], 2;
                            die qq(Option $_[0], key "$_[1]", requires a value\n)
                                unless @kv == 2;
                            %$ref = ($kv[0] => scalar $cb->($kv[1]));
                        }
                    }
                };
            }
            else {
                $destination = sub {
                    if ($t eq 'Array') {
                        $self->{opt}{$dest} ||= [];
                        push @{$self->{opt}{$dest}}, scalar $cb->($_[1]);
                    }
                    elsif ($t eq 'Hash') {
                        $self->{opt}{$dest} ||= {};
                        $self->{opt}{$dest}{$_[1]} = $cb->($_[2]);
                    }
                    else {
                        $self->{opt}{$dest} = $cb->($_[1]);
                    }
                };
            }
        }
        else {
            $destination = ref $ref ? $ref : \$self->{opt}{$dest};
        }
        if (exists $opts->{default}) {
            my $value = $opts->{default};
            if (ref $value eq 'ARRAY') {
                push @$default_args, map {
                    ("--$dest", $_)
                } grep { defined $_ } @$value;
            }
            elsif (ref $value eq 'HASH') {
                push @$default_args, map {
                    (my $key = $_) =~ s/=/\\=/g;
                    ("--$dest" => "$key=$value->{$_}")
                } grep {
                    defined $value->{$_}
                } keys %$value;
            }
            elsif (not ref $value) {
                if (!$spec || ($TYPE_MAP->{$spec} || $spec) eq '!') {
                    push @$default_args, "--$dest" if $value;
                }
                else {
                    push @$default_args, "--$dest", $value if defined $value;
                }
            }
            else {
                $self->{error} = "Invalid default option for $dest";
                $self->{ret} = 0;
            }
            $default_opthash->{$o} = $destination;
        }
        $opthash->{$o} = $destination;
        $self->{requires}{$dest} = $o if $opts->{required};
    }

    return if $self->{error};
    if (@$default_args) {
        $self->{ret} = $self->_parse_option($default_args, $default_opthash);
        unshift @ARGV, @$default_args;
        return unless $self->{ret};
    }

    return $opthash;
}

sub _init_struct {
    my ($self, $struct) = @_;
    $self->{struct} = ref $struct eq 'ARRAY' ? $struct : ref $struct eq 'HASH' ? $self->_normalize_struct($struct) : [];

    if (ref $self->{modes} eq 'ARRAY') {
        my @modeopt;
        for my $m (@{$self->{modes}}) {
            my($mc) = $m =~ /^(\w)/;
            push @modeopt, [[$mc, $m], qq($m mode)];
        }
        unshift @$struct, @modeopt;
    }

    unshift @{$self->{struct}}, [[qw(h help)], qq(this help message)]
        if $self->{usage} && !$self->_has_option('help');
}

sub _normalize_struct {
    my ($self, $struct) = @_;

    my $result = [];
    for my $option (keys %$struct) {
        my $data = $struct->{$option} || {};
        $data = ref $data eq 'HASH' ? $data : {};
        my $row = [];
        push @$row, [
            $option,
            ref $data->{alias} eq 'ARRAY' ? @{$data->{alias}} :
            defined $data->{alias}        ? $data->{alias}    :  (),
        ];
        push @$row, $data->{desc};
        push @$row, $data->{type};
        push @$row, $data->{dest};
        push @$row, $data->{opts};
        push @$result, $row;
    }

    return $result;
}

sub _compile_spec {
    my ($self, $spec) = @_;
    return if !defined $spec or $spec eq '';
    return $spec if $self->_opt_spec2name($spec);
    my ($type, $cb);
    if ($spec =~ /^(Array|Hash)\[(\w+)\]$/) {
        $type  = $TYPE_MAP->{$2} || Carp::croak("Can't find type constraint '$2'");
        $type .= $1 eq 'Array' ? '@' : '%';
        $cb    = $TYPE_GEN->{$2};
    }
    elsif ($type = $TYPE_MAP->{$spec}) {
        $cb = $TYPE_GEN->{$spec};
    }
    else {
        Carp::croak("Can't find type constraint '$spec'");
    }
    return $type, $cb;
}

sub add_type {
    my ($class, $name, $src_type, $cb) = @_;
    unless (defined $name && $src_type && ref $cb eq 'CODE') {
        Carp::croak("Usage: $class->add_type(\$name, \$src_type, \$cb)");
    }
    unless ($TYPE_MAP->{$src_type}) {
        Carp::croak("$src_type is not defined src type");
    }
    $TYPE_MAP->{$name} = $TYPE_MAP->{$src_type};
    $TYPE_GEN->{$name} = $cb;
}

sub _init_summary {
    my ($self, $command_struct) = @_;
    if ($command_struct) {
        for my $key (keys %$command_struct) {
            $self->{summary}{$key} = $command_struct->{$key}->{desc} || '';
        }
    }
    else {
        $self->{summary} = {};
    }
}

sub _extends_usage {
    my ($self, $command_option) = @_;
    for my $key (qw/args other_usage/) {
        $self->{$key} = $command_option->{$key} if exists $command_option->{$key};
    }
}

sub _check_requires {
    my ($self) = @_;
    for my $dest (sort keys %{$self->{requires}}) {
        unless (defined $self->{opt}{$dest}) {
            unless (defined ${$self->{parsed_opthash}{$self->{requires}{$dest}}}) {
                $self->{ret}   = 0;
                $self->{error} = "`--$dest` option must be specified";
                return 0;
            }
        }
    }
    return 1;
}

sub _option_names {
    my($self, $m) = @_;
    my @sorted = sort {
        my ($la, $lb) = (length($a), length($b));
        return $la <=> $lb if $la < 2 or $lb < 2;
        return 0;
    } ref $m eq 'ARRAY' ? @$m : $m;
    return @sorted;
}

sub _has_option {
    my($self, $option) = @_;
    return 1 if grep { $_ eq $option } map { $self->_option_names($_->[0]) } @{$self->{struct}};
    return 0;
}

1;
__END__