File Coverage

blib/lib/Getopt/Long/More.pm

Criterion	Covered	Total	%
statement	95	227	41.8
branch	58	142	40.8
condition	13	47	27.6
subroutine	8	18	44.4
pod	8	9	88.8
total	182	443	41.0

## no critic: Modules::ProhibitAutomaticExportation

package Getopt::Long::More;

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2020-04-08'; # DATE
our $DIST = 'Getopt-Long-More'; # DIST
our $VERSION = '0.007'; # VERSION

use strict;

use Exporter qw(import);

our @EXPORT    = qw(GetOptions optspec OptSpec);
our @EXPORT_OK = qw(HelpMessage VersionMessage Configure
                    GetOptionsFromArray GetOptionsFromString
                    OptionsPod);

sub optspec {
    Getopt::Long::More::OptSpec->new(@_);
}

# synonym for convenience
sub OptSpec {
    Getopt::Long::More::OptSpec->new(@_);
}

sub VersionMessage {
    require Getopt::Long;
    goto &Getopt::Long::VersionMessage;
}

sub Configure {
    require Getopt::Long;
    goto &Getopt::Long::Configure;
}

# copied verbatim from Getopt::Long, with a bit of modification (add my)
sub GetOptionsFromString(@) {
    my ($string) = shift;
    require Text::ParseWords;
    my $args = [ Text::ParseWords::shellwords($string) ];
    local $Getopt::Long::caller ||= (caller)[0];
    my $ret = GetOptionsFromArray($args, @_);
    return ( $ret, $args ) if wantarray;
    if ( @$args ) {
	$ret = 0;
	warn("GetOptionsFromString: Excess data \"@$args\" in string \"$string\"\n");
    }
    $ret;
}

# copied verbatim from Getopt::Long
sub GetOptions(@) {
    # Shift in default array.
    unshift(@_, \@ARGV);
    # Try to keep caller() and Carp consistent.
    goto &GetOptionsFromArray;
}

my $_cur_opts_spec = [];

sub GetOptionsFromArray {
    require Getopt::Long;

    my $ary = shift;

    local $Getopt::Long::caller ||= (caller)[0];  # grab and set this asap.

    my @go_opts_spec;

    if ( ref($_[0]) ) {
      require Scalar::Util;
      if ( Scalar::Util::reftype ($_[0]) eq 'HASH') {
        push @go_opts_spec, shift;  # 'hash-storage' is now directly supported
      }
    }

    my @opts_spec = @_;

    # provide explicit --help|?, for completion. also, we need to override the
    # option destination to use our HelpMessage.
    if ($Getopt::Long::auto_help) {
        unshift @opts_spec, 'help|?' => optspec(
            destination => sub { HelpMessage() },
            summary => 'Print help message and exit',
        );
    }
    local $Getopt::Long::auto_help = 0;

    # provide explicit --version, for completion
    if ($Getopt::Long::auto_version) {
        unshift @opts_spec, 'version' => optspec(
            destination => sub { VersionMessage() },
            summary => 'Print program version and exit',
        );
    }
    local $Getopt::Long::auto_version = 0;

    # to allow our HelpMessage to generate usage/help based on options spec
    $_cur_opts_spec = [@opts_spec];

    # strip the optspec objects
    my $prev;
    my $has_arg_handler;
    my $arg_handler_accessed;
  MAPPING:  # Resulting in the complete EVAPORATION of OptSpec objects, replaced by their destination, if one exists.
      for my $e (@opts_spec) {
        unless ( ref($e) eq 'Getopt::Long::More::OptSpec' ) {
          push @go_opts_spec, $e;
          next;
        }

        next unless exists $e->{destination};

        if ( $prev  eq '<>' ) {
          $has_arg_handler++;
          push @go_opts_spec, sub {
            $arg_handler_accessed++;
            $e->{destination}->(@_);
          };
        } else {
          push @go_opts_spec, $e->{destination};
        }
    } continue {
      $prev = $e;
    }

    # if in completion mode, do completion instead of parsing options
  COMPLETION: {
        my $shell;
        if ($ENV{COMP_SHELL}) {
            ($shell = $ENV{COMP_SHELL}) =~ s!.+/!!;
        } elsif ($ENV{COMMAND_LINE}) {
            $shell = 'tcsh';
        } else {
            $shell = 'bash';
        }

        if ($ENV{COMP_LINE} || $ENV{COMMAND_LINE}) {
            my ($words, $cword);
            if ($ENV{COMP_LINE}) {
                require Complete::Bash;
                ($words,$cword) = @{ Complete::Bash::parse_cmdline(undef, undef, {truncate_current_word=>1}) };
                ($words,$cword) = @{ Complete::Bash::join_wordbreak_words($words, $cword) };
            } elsif ($ENV{COMMAND_LINE}) {
                require Complete::Tcsh;
                $shell //= 'tcsh';
                ($words, $cword) = @{ Complete::Tcsh::parse_cmdline() };
            }

            my %opt_completions;
            my $arg_completion;
            for (my $i=0; $i < @opts_spec; $i++) {
                if ($i % 2 == 0) {
                    my $o = $opts_spec[$i];
                    my $os = $opts_spec[$i+1];
                    if (ref($os) eq 'Getopt::Long::More::OptSpec') {
                        my $completion = $os->{completion};
                        next unless $completion;
                        if (ref $completion eq 'ARRAY') {
                            $completion = sub {
                                require Complete::Util;
                                my %args = @_;
                                Complete::Util::complete_array_elem(
                                    word => $args{word},
                                    array => $os->{completion},
                                );
                            };
                        }
                        if ($o eq '<>') {
                            $arg_completion = $completion;
                        } else {
                            $opt_completions{$o} = $completion;
                        }
                    }
                }
            }

            my $comp = sub {
                my %args = @_;
                if ($args{type} eq 'optval' && $opt_completions{ $args{ospec} }) {
                    return $opt_completions{ $args{ospec} }->(%args);
                } elsif ($args{type} eq 'arg' && $arg_completion) {
                    return $arg_completion->(%args);
                }
                undef;
            };

            require Complete::Getopt::Long;
            shift @$words; $cword--; # strip program name
            my $compres = Complete::Getopt::Long::complete_cli_arg(
                words => $words, cword => $cword, getopt_spec => {@go_opts_spec},
                completion => $comp,
                bundling => $Gteopt::Long::bundling,
            );

            if ($shell eq 'bash') {
                require Complete::Bash;
                print Complete::Bash::format_completion(
                    $compres, {word=>$words->[$cword], workaround_with_wordbreaks=>0});
            } elsif ($shell eq 'fish') {
                require Complete::Fish;
                print Complete::Bash::format_completion(
                    $compres, {word=>$words->[$cword]});
            } elsif ($shell eq 'tcsh') {
                require Complete::Tcsh;
                print Complete::Tcsh::format_completion($compres);
            } elsif ($shell eq 'zsh') {
                require Complete::Zsh;
                print Complete::Zsh::format_completion($compres);
            } else {
                die "Unknown shell '$shell'";
            }

            exit 0;
        }
    }

    my $res = Getopt::Long::GetOptionsFromArray($ary, @go_opts_spec);

    my $i = -1;
    for (@opts_spec) {
        $i++;
        if ($i > 0 && ref($_) eq 'Getopt::Long::More::OptSpec') {
            my $osname = $opts_spec[$i-1];

            # check required
            if ($_->{required}) {
                if ($osname eq '<>') {
                    if ($has_arg_handler) {
                        unless ($arg_handler_accessed) {
                            die "Missing required command-line argument\n";
                        }
                    } else {
                        unless (@{ $ary }) {
                            die "Missing required command-line argument\n";
                        }
                    }
                } elsif ( exists $_->{destination} ) {
                    if (ref($_->{destination}) eq 'SCALAR'
                            && !defined(${$_->{destination}})) {
                        die "Missing required option $osname\n";
                        # XXX doesn't work yet?
                    } elsif (ref($_->{destination}) eq 'ARRAY' &&
                                 !@{$_->{destination}}) {
                        die "Missing required option $osname\n";
                        # XXX doesn't work yet?
                    } elsif (ref($_->{destination}) eq 'HASH'
                                 && !keys(%{$_->{destination}})) {
                        die "Missing required option $osname\n";
                    }
                } else {
                    die "Can't enforce 'required' status without also knowing the 'destination' for option '$osname'. "
                        . "You need to provide a 'destination' to optspec() in order to benefit from that feature\n";
                }
            }
            # supply default value
            if (defined $_->{default}) {
                if ($osname eq '<>') {
                    # currently ignored
                } elsif ( exists $_->{destination} ) {
                    if (ref($_->{destination}) eq 'SCALAR'
                            && !defined(${$_->{destination}})) {
                        ${$_->{destination}} = $_->{default};
                        # XXX doesn't work yet?
                    } elsif (ref($_->{destination}) eq 'ARRAY' &&
                                 !@{$_->{destination}}) {
                        $_->{destination} = [@{ $_->{default} }]; # shallow copy
                        # XXX doesn't work yet?
                    } elsif (ref($_->{destination}) eq 'HASH' &&
                                 !keys(%{$_->{destination}})) {
                        $_->{destination} = { %{ $_->{default} } }; # shallow copy
                    }
                } else {
                    die "Can't assign 'default' without also knowing the 'destination' for option '$osname'. "
                        . "You need to provide a 'destination' to optspec() in order to benefit from that feature\n";
                }
            }
        }
    }

    $res;
}

sub HelpMessage {
    my $opts_spec = @_ ? [@_] : $_cur_opts_spec;
    my $i = -1;
    my @entries;
    my $max_opt_spec_len = 0;
    for (my $i=0; $i < @$opts_spec; $i++) {
        if ($i % 2 == 0) {
            # normalize dashes at the front
            my $osname = $opts_spec->[$i];
            next if $osname eq '<>';
            $osname =~ s/^-+//;
            (my $oname = $osname) =~ s/[=|].*//;
            $osname = length($oname) > 1 ? "--$osname" : "-$osname";

            push @entries, [$osname, "", "", 0, undef]; # [opt, summary, desc, required?, default]
            my $len = length($osname);
            $max_opt_spec_len = $len if $max_opt_spec_len < $len;
            my $os = $opts_spec->[$i+1];
            if (ref($os) eq 'Getopt::Long::More::OptSpec') {
                $entries[-1][1] ||= $os->{summary};
                $entries[-1][3] = 1 if $os->{required};
                $entries[-1][4] = $os->{default};
            }
        }
    }

    my $prog = $0;
    $prog =~ s!.+[/\\]!!;

    print join(
        "",
        "Usage: $prog [options]\n",
        "Options (* marks required option):\n",
        map {
            sprintf("  %-${max_opt_spec_len}s%s  %s%s\n",
                    $_->[0],
                    $_->[3] ? "*" : " ",
                    $_->[1],
                    defined($_->[4]) ? " (default: $_->[4])" : "",
                )
        } @entries,
    );
    exit 0;
}

sub OptionsPod {
    my $opts_spec = @_ ? [@_] : $_cur_opts_spec;
    my $i = -1;
    my @entries;
    for (my $i=0; $i < @$opts_spec; $i++) {
        if ($i % 2 == 0) {
            # normalize dashes at the front
            my $osname = $opts_spec->[$i];
            next if $osname eq '<>';
            $osname =~ s/^-+//;
            (my $oname = $osname) =~ s/[=|].*//;
            $osname = length($oname) > 1 ? "--$osname" : "-$osname";

            push @entries, [$osname, "", "", 0, undef]; # [opt, summary, desc, required?, default]
            my $os = $opts_spec->[$i+1];
            if (ref($os) eq 'Getopt::Long::More::OptSpec') {
                $entries[-1][1] ||= $os->{summary};
                $entries[-1][2] ||= $os->{description};
                $entries[-1][3] = 1 if $os->{required};
                $entries[-1][4] = $os->{default};
            }
        }
    }

    my @res;

    push @res, "=head1 OPTIONS\n\n";
    for (@entries) {
        my @notes;
        if ($_->[3]) { push @notes, "required" }
        if (defined $_->[4]) { push @notes, "default: $_->[4]" }
        push @res, "=head2 $_->[0]", (@notes ? " (".join(", ", @notes).")" : ""), "\n\n";
        push @res, "$_->[1]\n\n" if length $_->[1];
        push @res, "$_->[2]\n\n" if length $_->[2];
    }

    join("", @res);

}

package # hide from PAUSE indexer
    Getopt::Long::More::Internal::Util;

# TAU: Named this ::Internal::Util because ::Util was already taken on CPAN.
our @CARP_NOT = qw( Getopt::Long::More Getopt::Long::More::Internal::Util  Getopt::Long::More::OptSpec);

# The subroutines here (::Util) are intended to be pretty generic
# and so could also be used elsewhere later on.

sub map_args {
  my %o = %{; shift || {} };  # shallow copy
  my %p = (@_);
  my ($deprecated, $aliases,
      $deprecated_aliases) =  map {; $_ || {} } @p{qw/deprecated aliases deprecated_aliases/};

  my %deprecations =  ( %$deprecated, %$deprecated_aliases );
  my %synonyms     =  ( %$aliases,    %$deprecated_aliases );

  # Deprecated => warn
  while ( my ($k, $canon) = each %deprecations )  {
    next unless exists $o{$k};
    require Carp;
    Carp::carp( "'$k' is deprecated!",
                ( defined($canon) ? " You should use '$canon' instead." : () ),
                "\n"
              );
  }

  # Synonym => map to canonical key.
  while ( my ($k, $canon) = each %synonyms ) {
    next unless exists $o{$k};

    my $v = delete $o{$k};
    next unless defined $canon; #  if $canon key is undefined => disregard

    if  ( exists $o{$canon} ) {
      require Carp;
      Carp::croak( "'$k' may only be used as a synonym for '$canon'; not alongside it.", "\n" );
    }

    $o{$canon} = $v;
  }
  wantarray ? (%o) : \%o;
}


package # hide from PAUSE indexer
    Getopt::Long::More::OptSpec;

# Poor man's import....
*map_args = \&Getopt::Long::More::Internal::Util::map_args;

sub new {
    my $class = shift;
    my $obj   = map_args( { @_ }, deprecated_aliases => { handler => 'destination' } );

    for (keys %$obj) {
        next if /\A(x|x\..+|_.*)\z/;
        unless (/\A(required|default|summary|description|destination|completion)\z/) {
            die "Unknown optspec property '$_'";
        }
    }
    bless $obj, $class;
}

1;
# ABSTRACT: Like Getopt::Long, but with more stuffs

__END__