File Coverage

blib/lib/OptArgs2.pm

Criterion	Covered	Total	%
statement	56	86	65.1
branch	10	26	38.4
condition	11	41	26.8
subroutine	14	21	66.6
pod	9	11	81.8
total	100	185	54.0

package OptArgs2;
use strict;
use warnings;
use Encode::Locale 'decode_argv';
use OptArgs2::Cmd;
use Exporter::Tidy
  default => [qw/class_optargs cmd optargs subcmd arg opt/],
  other   => [qw/usage cols rows/];

our $VERSION  = 'v2.0.17';
our @CARP_NOT = (
    qw/
      OptArgs2
      OptArgs2::Arg
      OptArgs2::Cmd
      OptArgs2::CmdBase
      OptArgs2::Opt
      OptArgs2::OptArgBase
      OptArgs2::SubCmd
      /
);

# constants
sub USAGE_USAGE()       { 'Usage' }         # default
sub USAGE_HELP()        { 'Help' }
sub USAGE_HELPTREE()    { 'HelpTree' }
sub USAGE_HELPSUMMARY() { 'HelpSummary' }

our $CURRENT;                               # legacy interface
my %COMMAND;
my @chars;

sub _chars {
    if ( $^O eq 'MSWin32' ) {
        require Win32::Console;
        @chars = Win32::Console->new()->Size();
    }
    else {
        require Term::Size::Perl;
        @chars = Term::Size::Perl::chars();
    }
    \@chars;
}

sub cols {
    $chars[0] // _chars()->[0];
}

sub rows {
    $chars[1] // _chars()->[1];
}

sub die_paged {
    my $err = shift // 'die_paged($ERR)';
    if ( -t STDERR ) {
        my $lines = scalar( split /\n/, $err );
        $lines++ if $err =~ m/\n\z/;

        if ( $lines >= OptArgs2::rows() ) {
            require OptArgs2::Pager;
            my $pager = OptArgs2::Pager->new( auto => 0 );
            local *STDERR = $pager->fh;
            die $err;
        }
    }

    die $err;
}

my %error_types = (
    CmdExists         => undef,
    CmdNotFound       => undef,
    Conflict          => undef,
    DuplicateAlias    => undef,
    InvalidIsa        => undef,
    ParentCmdNotFound => undef,
    SubCmdExists      => undef,
    UndefOptArg       => undef,
    Usage             => undef,
);

package OptArgs2::Status {
    use overload
      bool     => sub { 1 },
      '""'     => sub { ${ $_[0] } },
      fallback => 1;
}

sub croak {
    require Carp;
    my $type = shift // Carp::croak( 'Usage', 'croak($TYPE, [$msg])' );
    my $pkg  = 'OptArgs2::Error::' . $type;
    my $msg  = shift // "($pkg)";
    $msg = sprintf( $msg, @_ ) if @_;

    Carp::croak( 'Usage', "unknown error type: $type" )
      unless exists $error_types{$type};

    $msg .= ' ' . Carp::longmess('');

    no strict 'refs';
    *{ $pkg . '::ISA' } = ['OptArgs2::Status'];

    die_paged( bless \$msg, $pkg );
}

sub class_optargs {
    my $class = shift
      || croak( 'Usage', 'class_optargs($CMD,[@argv])' );

    my $cmd = $COMMAND{$class}
      || croak( 'CmdNotFound', 'command class not found: ' . $class );

    my @source = @_;

    if ( !@_ and @ARGV ) {
        decode_argv(Encode::FB_CROAK);
        @source = @ARGV;
    }

    $cmd->parse(@source);
}

sub cmd {
    my $class = shift || croak( 'Usage', 'cmd($CLASS,@args)' );

    croak( 'CmdExists', "command already defined: $class" )
      if exists $COMMAND{$class};

    $COMMAND{$class} = OptArgs2::Cmd->new( class => $class, @_ );
}

sub optargs {
    my $class = caller;

    if ( !@_ and exists $COMMAND{$class} ) {    # Legacy interface
        return ( class_optargs($class) )[1];
    }

    delete $COMMAND{$class};
    cmd( $class, @_ );
    ( class_optargs($class) )[1];
}

sub subcmd {
    my $class = shift || croak( 'Usage', 'subcmd($CLASS,%%args)' );

    croak( 'SubCmdExists', "subcommand already defined: $class" )
      if exists $COMMAND{$class};

    croak( 'ParentCmdNotFound',
        "no '::' in class '$class' - must have a parent" )
      unless $class =~ m/(.+)::(.+)/;

    my $parent_class = $1;

    croak( 'ParentCmdNotFound', "parent class not found: " . $parent_class )
      unless exists $COMMAND{$parent_class};

    $COMMAND{$class} = $COMMAND{$parent_class}->add_cmd(
        class => $class,
        @_
    );
}

sub usage {
    my $class = shift || do {
        my ($pkg) = caller;
        $pkg;
    };
    my $style = shift;

    croak( 'CmdNotFound', "command not found: $class" )
      unless exists $COMMAND{$class};

    return $COMMAND{$class}->usage_string($style);
}

# Legacy interface, no longer documented

sub arg {
    my $name  = shift;
    my $class = scalar caller;

    $OptArgs2::CURRENT //= cmd( $class, comment => '' );
    $OptArgs2::CURRENT->add_arg(
        name => $name,
        @_,
    );

}

sub opt {
    my $name  = shift;
    my $class = scalar caller;

    $OptArgs2::CURRENT //= cmd( $class, comment => '' );
    $OptArgs2::CURRENT->add_opt(
        name => $name,
        @_,
    );
}

1;

__END__