File Coverage

blib/lib/OptArgs2.pm

Criterion	Covered	Total	%
statement	319	451	70.7
branch	93	184	50.5
condition	48	144	33.3
subroutine	37	49	75.5
pod	9	23	39.1
total	506	851	59.4

use strict;
use warnings;

package OptArgs2;
use Encode qw/decode/;
use Exporter::Tidy
  default => [qw/class_optargs cmd optargs subcmd arg opt/],
  other   => [qw/usage cols rows/];

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

# constants
sub STYLE_USAGE()       { 'Usage' }         # default
sub STYLE_HELP()        { 'Help' }
sub STYLE_HELPTREE()    { 'HelpTree' }
sub STYLE_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];
}

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

sub throw_error {
    require Carp;

    my $proto = shift;
    my $type  = shift // Carp::croak( 'Usage', 'error($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 bless \$msg, $pkg;
}

my %usage_types = (
    ArgRequired      => undef,
    Help             => undef,
    HelpSummary      => undef,
    HelpTree         => undef,
    OptRequired      => undef,
    OptUnknown       => undef,
    SubCmdRequired   => undef,
    SubCmdUnknown    => undef,
    UnexpectedOptArg => undef,
);

sub throw_usage {
    my $proto = shift;
    my $type  = shift // $proto->error( 'Usage', 'usage($TYPE, $str)' );
    my $str   = shift // $proto->error( 'Usage', 'usage($type, $STR)' );
    my $pkg   = 'OptArgs2::Usage::' . $type;

    $proto->error( 'Usage', "unknown usage reason: $type" )
      unless exists $usage_types{$type};

    if ( -t STDERR ) {
        my $lines = scalar( split /\n/, $str );
        $lines++ if $str =~ m/\n\z/;

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

            no strict 'refs';
            *{ $pkg . '::ISA' } = ['OptArgs2::Status'];
            die bless \$str, $pkg;
        }
    }

    no strict 'refs';
    *{ $pkg . '::ISA' } = ['OptArgs2::Status'];
    die bless \$str, $pkg;
}

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

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

    my @source = @_;

    if ( !@_ and @ARGV ) {
        my $CODESET =
          eval { require I18N::Langinfo; I18N::Langinfo::CODESET() };

        if ($CODESET) {
            my $codeset = I18N::Langinfo::langinfo($CODESET);
            $_ = decode( $codeset, $_ ) for @ARGV;
        }

        @source = @ARGV;
    }

    $cmd->parse(@source);
}

sub cmd {
    my $class = shift || OptArgs2->throw_error( 'Usage', 'cmd($CLASS,@args)' );

    OptArgs2->throw_error( 'CmdExists', "command already defined: $class" )
      if exists $COMMAND{$class};

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

sub optargs {
    my $class = caller;
    cmd( $class, @_ );
    ( class_optargs($class) )[1];
}

sub subcmd {
    my $class =
      shift || OptArgs2->throw_error( 'Usage', 'subcmd($CLASS,%%args)' );

    OptArgs2->throw_error( 'SubCmdExists',
        "subcommand already defined: $class" )
      if exists $COMMAND{$class};

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

    my $parent_class = $1;

    OptArgs2->throw_error( '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;

    OptArgs2->throw_error( '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;

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

sub opt {
    my $name = shift;

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

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

package OptArgs2::CODEREF {
    our @CARP_NOT = @OptArgs2::CARP_NOT;

    sub TIESCALAR {
        my $class = shift;
        ( 3 == @_ )
          or Optargs2->throw_error( 'Usage', 'args: optargs,name,sub' );
        return bless [@_], $class;
    }

    sub FETCH {
        my $self = shift;
        my ( $optargs, $name, $sub ) = @$self;
        untie $optargs->{$name};
        $optargs->{$name} = $sub->($optargs);
    }
}

package OptArgs2::OptArgBase {
    use OptArgs2::OptArgBase_CI
      abstract => 1,
      has      => {
        comment      => { required => 1, },
        default      => {},
        getopt       => {},
        isa          => { required => 1, },
        isa_name     => { is       => 'rw', },
        name         => { required => 1, },
        required     => {},
        show_default => {},
      },
      ;

    our @CARP_NOT = @OptArgs2::CARP_NOT;
    our %isa2name = (
        'ArrayRef' => 'Str',
        'Bool'     => '',
        'Counter'  => '',
        'Flag'     => '',
        'HashRef'  => 'Str',
        'Int'      => 'Int',
        'Num'      => 'Num',
        'Str'      => 'Str',
        'SubCmd'   => 'Str',
    );

}

package OptArgs2::Arg {
    use OptArgs2::Arg_CI
      isa => 'OptArgs2::OptArgBase',
      has => {
        cmd      => { is => 'rw', weaken => 1, },
        fallthru => {},
        greedy   => {},
      };

    our @CARP_NOT = @OptArgs2::CARP_NOT;
    my %arg2getopt = (
        'Str'      => '=s',
        'Int'      => '=i',
        'Num'      => '=f',
        'ArrayRef' => '=s@',
        'HashRef'  => '=s%',
        'SubCmd'   => '=s',
    );

    sub BUILD {
        my $self = shift;

        OptArgs2->throw_error( 'Conflict',
            q{'default' and 'required' conflict} )
          if $self->required and defined $self->default;
    }

    sub name_alias_type_comment {
        my $self  = shift;
        my $value = shift;

        my $deftype = '';
        if ( defined $value ) {
            $deftype = '[' . $value . ']';
        }
        else {
            $deftype = $self->isa_name
              // $OptArgs2::OptArgBase::isa2name{ $self->isa }
              // OptArgs2->throw_error( 'InvalidIsa',
                'invalid isa type: ' . $self->isa );
        }

        my $comment = $self->comment;
        if ( $self->required ) {
            $comment .= ' ' if length $comment;
            $comment .= '*required*';
        }

        return $self->name, '', $deftype, $comment;
    }

}

package OptArgs2::Opt {
    use OptArgs2::Opt_CI
      isa => 'OptArgs2::OptArgBase',
      has => {
        alias   => {},
        hidden  => {},
        trigger => {},
      };

    our @CARP_NOT = @OptArgs2::CARP_NOT;

    my %isa2getopt = (
        'ArrayRef' => '=s@',
        'Bool'     => '!',
        'Counter'  => '+',
        'Flag'     => '!',
        'HashRef'  => '=s%',
        'Int'      => '=i',
        'Num'      => '=f',
        'Str'      => '=s',
    );

    sub new_from {
        my $proto = shift;
        my $ref   = {@_};

        # legacy interface
        if ( exists $ref->{ishelp} ) {
            delete $ref->{ishelp};
            $ref->{isa} //= OptArgs2::STYLE_HELP;
        }

        if ( $ref->{isa} =~ m/^Help/ ) {    # one of the STYLE_HELPs
            my $style = $ref->{isa};
            my $name  = $style;
            $name =~ s/([a-z])([A-Z])/$1-$2/g;
            $ref->{isa} = 'Counter';
            $ref->{name}    //= lc $name;
            $ref->{alias}   //= lc substr $ref->{name}, 0, 1;
            $ref->{comment} //= "print a $style message and exit";
            $ref->{trigger} //= sub {
                my $cmd = shift;
                my $val = shift;

                if ( $val == 1 ) {
                    OptArgs2->throw_usage( OptArgs2::STYLE_HELP,
                        $cmd->usage_string(OptArgs2::STYLE_HELP) );
                }
                elsif ( $val == 2 ) {
                    OptArgs2->throw_usage( OptArgs2::STYLE_HELPTREE,
                        $cmd->usage_string(OptArgs2::STYLE_HELPTREE) );
                }
                else {
                    OptArgs2->throw_usage(
                        'UnexpectedOptArg',
                        $cmd->usage_string(
                            OptArgs2::STYLE_USAGE,
                            qq{"--$ref->{name}" used too many times}
                        )
                    );
                }
            };
        }

        if ( !exists $isa2getopt{ $ref->{isa} } ) {
            return OptArgs2->throw_error( 'InvalidIsa',
                'invalid isa "%s" for opt "%s"',
                $ref->{isa}, $ref->{name} );
        }

        $ref->{getopt} = $ref->{name};
        if ( $ref->{name} =~ m/_/ ) {
            ( my $x = $ref->{name} ) =~ s/_/-/g;
            $ref->{getopt} .= '|' . $x;
        }
        $ref->{getopt} .= '|' . $ref->{alias} if $ref->{alias};
        $ref->{getopt} .= $isa2getopt{ $ref->{isa} };

        return $proto->new(%$ref);
    }

    sub name_alias_type_comment {
        my $self  = shift;
        my $value = shift;

        ( my $opt = $self->name ) =~ s/_/-/g;
        if ( $self->isa eq 'Bool' ) {
            if ($value) {
                $opt = 'no-' . $opt;
            }
            elsif ( not defined $value ) {
                $opt = '[no-]' . $opt;
            }
        }
        $opt = '--' . $opt;

        my $alias = $self->alias // '';
        if ( length $alias ) {
            $opt .= ',';
            $alias = '-' . $alias;
        }

        my $deftype = '';
        if ( defined $value ) {
            if ( $self->isa eq 'Flag' ) {
                $deftype = '(set)';
            }
            elsif ( $self->isa eq 'Bool' ) {
                $deftype = '(' . ( $value ? 'true' : 'false' ) . ')';
            }
            elsif ( $self->isa eq 'Counter' ) {
                $deftype = '(' . $value . ')';
            }
            else {
                $deftype = '[' . $value . ']';
            }
        }
        else {
            $deftype = $self->isa_name
              // $OptArgs2::OptArgBase::isa2name{ $self->isa }
              // OptArgs2->throw_error( 'InvalidIsa',
                'invalid isa type: ' . $self->isa );
        }

        my $comment = $self->comment;
        if ( $self->required ) {
            $comment .= ' ' if length $comment;
            $comment .= '*required*';
        }

        return $opt, $alias, $deftype, $comment;
    }

}

package OptArgs2::CmdBase {
    use overload
      bool     => sub { 1 },
      '""'     => sub { shift->class },
      fallback => 1;
    use Getopt::Long qw/GetOptionsFromArray/;
    use List::Util qw/max/;
    use OptArgs2::CmdBase_CI
      abstract => 1,
      has      => {
        abbrev  => { is       => 'rw', },
        args    => { default  => sub { [] }, },
        class   => { required => 1, },
        comment => { required => 1, },
        hidden  => {},
        optargs => {
            is      => 'rw',
            default => sub { [] }
        },
        opts   => { default => sub { [] }, },
        parent => { weaken  => 1, },
        _opts  => {
            default => sub { {} }
        },
        _args => {
            default => sub { {} }
        },
        _subcmds => {
            default => sub { {} }
        },
        show_default => { default => 0, },
        show_color   => { default => sub { -t STDERR }, },
        subcmds      => { default => sub { [] }, },
        _values      => { is      => 'rw' },
      },
      ;

    our @CARP_NOT = @OptArgs2::CARP_NOT;

    sub BUILD {
        my $self = shift;

        # legacy interface
        if ( 'CODE' eq ref $self->optargs ) {
            local $OptArgs2::CURRENT = $self;
            $self->optargs->();
            return;
        }

        while ( my ( $name, $args ) = splice @{ $self->optargs }, 0, 2 ) {
            if ( $args->{isa} =~ s/^--// ) {
                $self->add_opt(
                    name => $name,
                    %$args,
                );
            }
            else {
                $self->add_arg(
                    name => $name,
                    %$args,
                );
            }
        }
    }

    sub add_arg {
        my $self = shift;
        my $arg  = OptArgs2::Arg->new(
            cmd          => $self,
            show_default => $self->show_default,
            @_,
        );

        push( @{ $self->args }, $arg );
        $arg;
    }

    sub add_cmd {
        my $self   = shift;
        my $subcmd = OptArgs2::SubCmd->new(
            abbrev       => $self->abbrev,
            show_default => $self->show_default,
            @_,
            parent => $self,
        );

        OptArgs2->throw_error( 'CmdExists', 'cmd exists' )
          if exists $self->_subcmds->{ $subcmd->name };

        $self->_subcmds->{ $subcmd->name } = $subcmd;
        push( @{ $self->subcmds }, $subcmd );

        return $subcmd;
    }

    sub add_opt {
        my $self = shift;
        my $opt  = OptArgs2::Opt->new_from(
            show_default => $self->show_default,
            @_,
        );

        push( @{ $self->opts }, $opt );
        $opt;
    }

    sub parents {
        my $self = shift;
        return unless $self->parent;
        return ( $self->parent->parents, $self->parent );
    }

    sub parse {
        my $self   = shift;
        my $source = \@_;

        map {
            OptArgs2->throw_error( 'UndefOptArg',
                'optargs argument undefined!' )
              if !defined $_
        } @$source;

        my $source_hash = { map { %$_ } grep { ref $_ eq 'HASH' } @$source };
        $source = [ grep { ref $_ ne 'HASH' } @$source ];

        Getopt::Long::Configure(qw/pass_through no_auto_abbrev no_ignore_case/);

        my $reason;
        my $optargs = {};
        my @trigger;

        my $cmd = $self;

        # Start with the parents options
        my @opts = map { @{ $_->opts } } $cmd->parents, $cmd;
        my @args = @{ $cmd->args };

      OPTARGS: while ( @opts or @args ) {
            while ( my $try = shift @opts ) {
                my $result;
                my $name = $try->name;

                if ( exists $source_hash->{$name} ) {
                    $result = delete $source_hash->{$name};
                }
                else {
                    GetOptionsFromArray( $source, $try->getopt => \$result );
                }

                if ( defined($result) and my $t = $try->trigger ) {
                    push @trigger, [ $t, $name ];
                }

                if ( defined( $result //= $try->default ) ) {

                    if ( 'CODE' eq ref $result ) {
                        tie $optargs->{$name}, 'OptArgs2::CODEREF', $optargs,
                          $name,
                          $result;
                    }
                    else {
                        $optargs->{$name} = $result;
                    }
                }
                elsif ( $try->required ) {
                    $name =~ s/_/-/g;
                    $reason //=
                      [ 'OptRequired', qq{missing required option "--$name"} ];
                }
            }

            # Sub command check
            if ( @$source and my @subcmds = @{ $cmd->subcmds } ) {
                my $result = $source->[0];
                if ( $cmd->abbrev ) {
                    require Text::Abbrev;
                    my %abbrev =
                      Text::Abbrev::abbrev( map { $_->name } @subcmds );
                    $result = $abbrev{$result} // $result;
                }

                if ( exists $cmd->_subcmds->{$result} ) {
                    shift @$source;
                    $cmd = $cmd->_subcmds->{$result};
                    push( @opts, @{ $cmd->opts } );

                    # Ignoring any remaining arguments
                    @args = @{ $cmd->args };

                    next OPTARGS;
                }
            }

            while ( my $try = shift @args ) {
                my $result;
                my $name = $try->name;

                if (@$source) {
                    if (
                        #                        $try->isa ne 'SubCmd'
                        #                        and (
                        ( $source->[0] =~ m/^--\S/ )
                        or (
                            $source->[0] =~ m/^-\S/
                            and !(
                                $source->[0] =~ m/^-\d/
                                and (  $try->isa ne 'Num'
                                    or $try->isa ne 'Int' )
                            )
                        )
                      )

                      #                      )
                    {
                        my $o = shift @$source;
                        $reason //= [ 'OptUnknown', qq{unknown option "$o"} ];
                        last OPTARGS;
                    }

                    if ( $try->greedy ) {

                        # Interesting feature or not? "GREEDY... LATER"
                        # my @later;
                        # if ( @args and @$source > @args ) {
                        #     push( @later, pop @$source ) for @args;
                        # }
                        # Should also possibly check early for post-greedy arg,
                        # except they might be wanted for display
                        # purposes

                        if ( $try->isa eq 'ArrayRef' or $try->isa eq 'SubCmd' )
                        {
                            $result = [@$source];
                        }
                        elsif ( $try->isa eq 'HashRef' ) {
                            $result = {
                                map { split /=/, $_ }
                                  split /,/, @$source
                            };
                        }
                        else {
                            $result = "@$source";
                        }

                        $source = [];

                        #                        $source = \@later;
                    }
                    elsif ( $try->isa eq 'ArrayRef' ) {
                        $result = [ shift @$source ];
                    }
                    elsif ( $try->isa eq 'HashRef' ) {
                        $result =
                          { map { split /=/, $_ } split /,/, shift @$source };
                    }
                    else {
                        $result = shift @$source;
                    }

                    # TODO: type check using Param::Utils?
                }
                elsif ( exists $source_hash->{$name} ) {
                    $result = delete $source_hash->{$name};
                }

                if ( defined( $result //= $try->default ) ) {
                    $reason //= [
                        'SubCmdUnknown',
                        "unknown $name: "
                          . (
                            ( 'ARRAY' eq ref $result )  ? $result->[0]
                            : ( 'HASH' eq ref $result ) ? (
                                join ',',
                                map { "$_=$result->{$_}" } keys %$result
                              )
                            : $result
                          )
                      ]
                      if $try->isa eq 'SubCmd' and not $try->fallthru;

                    if ( 'CODE' eq ref $result ) {
                        tie $optargs->{$name}, 'OptArgs2::CODEREF', $optargs,
                          $name,
                          $result;
                    }
                    else {
                        $optargs->{$name} = $result;
                    }
                }
                elsif ( $try->required ) {
                    $reason //= ['ArgRequired'];
                }
            }
        }

        if (@$source) {
            $reason //= [
                'UnexpectedOptArg',
                "unexpected option(s) or argument(s): @$source"
            ];
        }
        elsif ( my @unexpected = keys %$source_hash ) {
            $reason //= [
                'UnexpectedHashOptArg',
                "unexpected HASH option(s) or argument(s): @unexpected"
            ];
        }

        $cmd->_values($optargs);

        map { $_->[0]->( $cmd, $optargs->{ $_->[1] } ) } @trigger;

        OptArgs2->throw_usage( $reason->[0],
            $cmd->usage_string( OptArgs2::STYLE_USAGE, $reason->[1] ) )
          if $reason;

        return ( $cmd->class, $optargs, ( $cmd->class . '.pm' ) =~ s!::!/!gr );
    }

    sub _usage_tree {
        my $self  = shift;
        my $depth = shift || 0;

        return [
            $depth, $self->usage_string(OptArgs2::STYLE_HELPSUMMARY),
            $self->comment
          ],
          map { $_->_usage_tree( $depth + 1 ) }
          sort { $a->name cmp $b->name } @{ $self->subcmds };
    }

    sub usage_string {
        my $self  = shift;
        my $style = shift || OptArgs2::STYLE_USAGE;
        my $error = shift // '';
        my $usage = '';

        if ( $style eq OptArgs2::STYLE_HELPTREE ) {
            my ( @w1, @w2 );
            my @items = map {
                $_->[0] = ' ' x ( $_->[0] * 3 );
                push @w1, length( $_->[1] ) + length( $_->[0] );
                push @w2, length $_->[2];
                $_
            } $self->_usage_tree;
            my ( $w1, $w2 ) = ( max(@w1), max(@w2) );

            my $paged  = OptArgs2::rows() < scalar @items;
            my $cols   = OptArgs2::cols();
            my $usage  = '';
            my $spacew = 3;
            my $space  = ' ' x $spacew;

            foreach my $i ( 0 .. $#items ) {
                my $overlap = $w1 + $spacew + $w2[$i] - $cols;
                if ( $overlap > 0 and not $paged ) {
                    $items[$i]->[2] =
                      sprintf '%-.' . ( $w2[$i] - $overlap - 3 ) . 's%s',
                      $items[$i]->[2], '.' x 3;
                }
                $usage .= sprintf "%-${w1}s${space}%-s\n",
                  $items[$i]->[0] . $items[$i]->[1],
                  $items[$i]->[2];
            }
            return $usage;
        }

        my @parents = $self->parents;
        my @args    = @{ $self->args };
        my @opts =
          sort { $a->name cmp $b->name } map { @{ $_->opts } } @parents,
          $self;

        my $optargs = $self->_values;

        # Summary line
        $usage .= join( ' ', map { $_->name } @parents ) . ' '
          if @parents and $style ne OptArgs2::STYLE_HELPSUMMARY;
        $usage .= $self->name;

        my ( $red, $grey, $reset ) = ( '', '', '' );
        if ( $self->show_color ) {
            $red   = "\e[0;31m";
            $grey  = "\e[1;30m";
            $reset = "\e[0m";

            # $red      = "\e[0;31m";
            # $yellow = "\e[0;33m";
        }

        $error = $red . 'error:' . $reset . ' ' . $error . "\n\n"
          if length $error;

        foreach my $arg (@args) {
            $usage .= ' ';
            $usage .= '[' unless $arg->required;
            $usage .= uc $arg->name;
            $usage .= '...' if $arg->greedy;
            $usage .= ']' unless $arg->required;
        }

        return $usage if $style eq OptArgs2::STYLE_HELPSUMMARY;

        $usage .= ' [OPTIONS...]' if @opts;
        $usage .= "\n";

        # Synopsis
        $usage .= "\n  Synopsis:\n    " . $self->comment . "\n"
          if $style eq OptArgs2::STYLE_HELP and length $self->comment;

        # Build arguments
        my @sargs;
        my @uargs;
        my $have_subcmd;

        if (@args) {
            my $i = 0;
          ARG: foreach my $arg (@args) {
                if ( $arg->isa eq 'SubCmd' ) {
                    my ( $n, undef, undef, $c ) =
                      $arg->name_alias_type_comment(
                        $arg->show_default
                        ? eval { $optargs->{ $arg->name } // undef }
                        : ()
                      );
                    push( @sargs, [ '  ' . ucfirst($n) . ':', $c ] );
                    my @sorted_subs =
                      map  { $_->[1] }
                      sort { $a->[0] cmp $b->[0] }
                      map  { [ $_->name, $_ ] }
                      grep { $style eq OptArgs2::STYLE_HELP or !$_->hidden }
                      @{ $arg->cmd->subcmds };

                    foreach my $subcmd (@sorted_subs) {
                        push(
                            @sargs,
                            [
                                '    '
                                  . $subcmd->usage_string(
                                    OptArgs2::STYLE_HELPSUMMARY),
                                $subcmd->comment
                            ]
                        );
                    }

                    $have_subcmd++;
                    last ARG;
                }
                else {
                    push( @uargs, [ '  Arguments:', '', '', '' ] ) if !$i;
                    my ( $n, $a, $t, $c ) = $arg->name_alias_type_comment(
                        $arg->show_default
                        ? eval { $optargs->{ $arg->name } // undef }
                        : ()
                    );
                    push( @uargs, [ '    ' . uc($n), $a, $t, $c ] );
                }
                $i++;
            }
        }

        # Build options
        my @uopts;
        if (@opts) {
            push( @uopts, [ "  Options:", '', '', '' ] );
            foreach my $opt (@opts) {
                next if $style ne OptArgs2::STYLE_HELP and $opt->hidden;
                my ( $n, $a, $t, $c ) = $opt->name_alias_type_comment(
                    $opt->show_default
                    ? eval { $optargs->{ $opt->name } // undef }
                    : ()
                );
                push( @uopts, [ '    ' . $n, $a, $t, $c ] );
            }
        }

        # Width calculation for args and opts combined
        my $w1 = max( 0,               map { length $_->[0] } @uargs, @uopts );
        my $w2 = max( 0,               map { length $_->[1] } @uargs, @uopts );
        my $w3 = max( 0,               map { length $_->[2] } @uargs, @uopts );
        my $w4 = max( 0,               map { length $_->[0] } @sargs );
        my $w5 = max( $w1 + $w2 + $w3, $w4 );

        my $format1 = "%-${w5}s  %s\n";
        my $format2 = "%-${w1}s %-${w2}s %-${w3}s";

        # Output Arguments
        if (@sargs) {
            $usage .= "\n";
            foreach my $row (@sargs) {
                $usage .= sprintf( $format1, @$row ) =~
                  s/^(\s+\w+\s)(.*?)(\s\s)/$1$grey$2$reset$3/r;
            }
        }

        if (@uargs) {
            $usage .= "\n";
            foreach my $row (@uargs) {
                my $l = pop @$row;
                $usage .= sprintf( $format1, sprintf( $format2, @$row ), $l );
            }
        }

        # Output Options
        if (@uopts) {
            $usage .= "\n";
            foreach my $row (@uopts) {
                my $l = pop @$row;
                $usage .= sprintf( $format1, sprintf( $format2, @$row ), $l );
            }
        }

        return $error . 'usage: ' . $usage . "\n";
    }

}

package OptArgs2::Cmd {
    use OptArgs2::Cmd_CI
      isa => 'OptArgs2::CmdBase',
      has => {
        name => {
            default => sub {
                my $x = $_[0]->class;

                # once legacy code goes move this into optargs()
                if ( $x eq 'main' ) {
                    require File::Basename;
                    File::Basename::basename($0),;
                }
                else {
                    $x =~ s/.*://;
                    $x =~ s/_/-/g;
                    $x;
                }
            },
        },
        no_help => { default => 0 },
      };

    our @CARP_NOT = @OptArgs2::CARP_NOT;

    sub BUILD {
        my $self = shift;

        $self->add_opt(
            isa          => OptArgs2::STYLE_HELP,
            show_default => 0,
          )
          unless $self->no_help
          or 'CODE' eq ref $self->optargs;    # legacy interface
    }
}

package OptArgs2::SubCmd {
    use OptArgs2::SubCmd_CI
      isa => 'OptArgs2::CmdBase',
      has => {
        name => {    # once legacy code goes move this into CmdBase
            init_arg => undef,
            default  => sub {
                my $x = $_[0]->class;
                $x =~ s/.*://;
                $x =~ s/_/-/g;
                $x;
            },
        },
        parent => { required => 1, },
      };

    our @CARP_NOT = @OptArgs2::CARP_NOT;
}

1;

__END__