view release on metacpan or  search on metacpan

lib/App/Cmdline.pm  view on Meta::CPAN

#-----------------------------------------------------------------
# App::Cmdline
# Author: Martin Senger <martin.senger@gmail.com>
# For copyright and disclaimer see the POD.
#
# ABSTRACT: helper for writing command-line applications
# PODNAME: App::Cmdline
#-----------------------------------------------------------------
use warnings;
use strict;

package App::Cmdline;
use parent 'App::Cmd::Simple';

our $VERSION = '0.1.2'; # VERSION

BEGIN {
    # we need to say no_auto_version early
    use Getopt::Long qw(:config no_auto_version);
}
use Sub::Install;

# ----------------------------------------------------------------
# Return the command-line script usage (the 1st line of the
# Usage). The content of the usage slightly differs depending on the
# configuration options used.
# ----------------------------------------------------------------
sub usage_desc {
    my $self = shift;
    my $config = { map { $_ => 1 } @{ $self->getopt_conf() } };
    if (exists $config->{'no_bundling'}) {
        return "%c [short or long options, not bundled]";
    } else {
        return "%c %o";
    }
}

# ----------------------------------------------------------------
# Create (and return) option definitions from wanted option sets
# (given as class names). Also install the validate_args() subroutine
# that will call validate_opts() on all wanted option sets.
# ----------------------------------------------------------------
sub composed_of {
    my $self = shift;
    my @option_classes = @_;  # list of class names with wanted options sets

    # create option definitions
    my @opt_spec = ();
    foreach my $set (@option_classes) {
        push (@opt_spec, $set) and next if ref ($set);
        ## no critic
        eval "require $set";
        if ($set->can ('get_opt_spec')) {
            push (@opt_spec, $set->get_opt_spec());
        } else {
            warn "Cannot find the set of options $set. The set is, therefore, ignored.\n";
        }
    }

    # install a dispatcher of all validating methods
    Sub::Install::reinstall_sub ({
        code => sub {
            foreach my $set (@option_classes) {
                next if ref ($set);
                if ($set->can ('validate_opts')) {
                    $set->validate_opts ($self, @_);
                }
            }
        },
        as   => 'validate_args',
                               });
    # add the configuration options
    return (@opt_spec, { getopt_conf => $self->getopt_conf() } );
}

# ----------------------------------------------------------------
# Check if the given set of options has duplications. Warn if yes.
# ----------------------------------------------------------------