File Coverage

blib/lib/Getopt/ApacheCommonsCLI.pm

Criterion	Covered	Total	%
statement	83	94	88.3
branch	27	44	61.3
condition	3	6	50.0
subroutine	11	12	91.6
pod	0	2	0.0
total	124	158	78.4

package Getopt::ApacheCommonsCLI;

use 5.008008;
use strict;
use warnings;

require Exporter;

our @ISA = qw(Exporter);

our %EXPORT_TAGS = ();

use constant OPT_PREC_UNIQUE        => 1;
use constant OPT_PREC_LEFT_TO_RIGHT => 0;
use constant OPT_PREC_RIGHT_TO_LEFT => 2;

our @EXPORT_OK = qw(
 GetOptionsApacheCommonsCLI
 OPT_PREC_UNIQUE
 OPT_PREC_LEFT_TO_RIGHT
 OPT_PREC_RIGHT_TO_LEFT
);

our @EXPORT = qw(
);

our $VERSION = '0.01';

# Preloaded methods go here.

use Getopt::Long 2.35;

sub GetOptionsApacheCommonsCLI {
   my ($rspec, $ropts, $roptions, $rerrsub) = @_;

   # process user-supplied options
   my $DEBUG      = defined $roptions->{'DEBUG'} ? $roptions->{'DEBUG'} : 0;
   my $JAVA_DOPTS = defined $roptions->{'JAVA_DOPTS'} ? $roptions->{'JAVA_DOPTS'} : 0;
   my $OPT_PREC   = defined $roptions->{'OPT_PRECEDENCE'} ? $roptions->{'OPT_PRECEDENCE'} : OPT_PREC_RIGHT_TO_LEFT;
   my $BUNDLING   = defined $roptions->{'BUNDLING'} ? $roptions->{'BUNDLING'} : 1;
   my $rambigs    = defined $roptions->{'AMBIGUITIES'} ? $roptions->{'AMBIGUITIES'} : undef; # reserved for future use

   $ropts->{__argv__}   = '';
   $ropts->{__errors__} = [];
   $ropts->{__argv_original__} = join(' ', @ARGV);

   my @GO_config = qw(pass_through no_auto_abbrev no_ignore_case prefix_pattern=--|-); # passed to Getopt::Long for behavior of Apache Common CLI Java library

   if ($BUNDLING) {
      push @GO_config, 'bundling_override';
   }

   my @GO_options;

   # setup a validation handler for missing argument
   if (ref($rerrsub) ne 'CODE') {
      $rerrsub = sub { my ($option, $value, $rhash) = @_; print "error: missing value for option: $option\n"; die "!FINISH"; };
   }

   my %longs;

   # read user input specification and process for Getopt::Long
   for my $s (@{$rspec}) {
      my ($long, $short, $type) = $s =~ /([a-zA-Z0-9_-]+)\|([a-zA-Z0-9]*)[=:]?([fios]*)/;
      next if $long eq '';

      if ($short eq '') {
         $short = $long;
      }

      if (length($short) > length($long)) {
         ($short, $long) = ($long, $short);
      }

      $longs{$long} = $short;

      # use either the first or second anonymous subroutine as a reference (we are not calling them ... GO will call them)
      push @GO_options, ($s, $type ne '' ?
           sub {
               my ($option, $value, $rhash) = @_;

               if (not defined $value or $value eq "") {
                  push @{$ropts->{__errors__}}, "no value for option $option";
                  &$rerrsub($option, $value, 0);
                  return 0;
               }

               if (exists $ropts->{$option}) {
                  if ($OPT_PREC == OPT_PREC_UNIQUE) {
                     push @{$ropts->{__errors__}}, "duplicate option $option with $value";
                     &$rerrsub($option, $value, 1);
                     return 0;
                  }
                  elsif ($OPT_PREC == OPT_PREC_RIGHT_TO_LEFT) {
                     $ropts->{$option} = $value;
                  }
                  elsif ($OPT_PREC == OPT_PREC_LEFT_TO_RIGHT) {
                     ; # ignore
                  }
                }
                else {
                    $ropts->{$option} = $value;
                }
           } :
           sub {
               my ($option, $value, $rhash) = @_;

               $ropts->{$option} = 1; # boolean option
           }
      );
   }

#   # bundling_override handles this fairly well ...
#
#   # args pre-processing - to reduce parsing ambiguities, replace some of the short options with long options before calling Getopt::Long
#
#   if (scalar(@ARGV) > 0) {
#      for (my $n=0; $n < scalar(@ARGV); $n++) {
#          last if $ARGV[$n] eq '--';
#          $ARGV[$n] =~ s/^-([\w]+)$/exists $longs{$1} ? "--$1" : "-$1"/e; # double-dash long args which only start with a single-dash
#          $ARGV[$n] =~ s/^(--?)([\w]{2,3})$/exists $rambigs->{$2} ? "--$rambigs->{$2}" : "$1$2"/e; # convert short options to long options because of bundling ambiguity
#      }
#   }

   Getopt::Long::Configure(@GO_config);
   my $result = GetOptions(@GO_options);

   # args post-processing
   if (scalar(@ARGV)) {
      if ($JAVA_DOPTS) {
         for (my $n=0; $n < scalar(@ARGV); $n++) {
             if ($ARGV[$n] eq '--') {
                last;
             }
             $ARGV[$n] =~ s/^ +//;
             $ARGV[$n] =~ s/ +$//;
             $ARGV[$n] =~ s/^--?D(\w+)=['"]?([\w.]+)['"]?$/$ropts->{$1} = $2; '';/e; # process -Dabc=z.y.z, overwrite existing values in the special case of -D (behavior is like OPT_PREC_RIGHT_TO_LEFT)
         }
      }
   }

   my $cmd = join(' ', @ARGV);
   $cmd =~ s/ +/ /g; # is there a case where we care about embedded spaces in remaining ARGV?
   $cmd =~ s/^ +//g;
   $cmd =~ s/ +$//g;

   if ($DEBUG) {
      debug_print($ropts) if $DEBUG;
      print "cmd=$cmd\n";
   }

   # stash remaining ARGV in the output hash
   $ropts->{'__argv__'} = $cmd;

   if ($result == 0 or @{$ropts->{'__errors__'}}) {
      return 0; # failure (according to Getopt::Long protocol)
   }
   else {
      return 1; # success (according to Getopt::Long protocol)
   }
}

# sub value_not_required {
# # option arg not expected, but we still want to set it to 1
#    my ($option, $value, $rhash) = @_;
#
#    if ($option ne "") {
#       $ropts->{$option} = 1;
#    }
# }
#
# sub value_required {
# # option arg expected, do error handling if missing, including a custom error message
#    my ($option, $value, $rhash) = @_;
#
#    if ($option ne "") {
#       if (not defined $value or $value eq "") {
#          print "Missing argument for option:$option\n";
#          $n_errs++;
#          die "!FINISH";
#       }
#       else {
#          if (exists $ropts->{$option} and $OPT_PREC == OPT_PREC_UNIQUE) {
#             print "Unrecognized command: $value\n";
#             $n_errs++;
#             die "!FINISH";
#          }
#          elsif (exists $ropts->{$option} and $OPT_PREC == OPT_PREC_LEFT_TO_RIGHT) {
#             ;
#          }
#          else {
#             $ropts->{$option} = $value;
#          }
#       }
#    }
# }

sub debug_print {
   my ($ropts) = @_;

   for my $o (sort keys %{$ropts}) {
      print "$o=$ropts->{$o}\n";
   }
}
1;
__END__