File Coverage

blib/lib/CBSSports/Getopt.pm

Criterion	Covered	Total	%
statement	62	96	64.5
branch	16	36	44.4
condition	2	8	25.0
subroutine	12	17	70.5
pod	3	3	100.0
total	95	160	59.3

package CBSSports::Getopt;
use warnings;
use strict;
use Getopt::Long qw();
use File::Basename qw(basename);
use Exporter 'import';
our @EXPORT    = qw(GetOptions Usage Configure);
our $VERSION = '1.1';

our $PRESET_OPTIONS = {
    h       => 'help',
    help    => 'help',
    v       => 'verbose',
    verbose => 'verbose',
    H       => 'man',
    man     => 'man',
    version => 'version',
};

our $ALLOW_PRESET_OVERRIDE = 0;

sub GetOptions {
    my (@option_args) = @_;
    my %opts = ();
    _merge_config_file_options();
    Getopt::Long::Configure( 'no_auto_abbrev', 'no_ignore_case', 'bundling' );
    Getopt::Long::GetOptions( _filter_options( \%opts, \@option_args ) ) || Usage( verbose => 0 );
    _print_version() if $opts{version};
    _clean_options( \%opts );
    return wantarray ? %opts : \%opts;
}

sub Usage {
    my %args = @_;
    print $args{message}, "\n" if $args{message};
    require Pod::Usage && Pod::Usage::pod2usage(
        '-verbose' => $args{verbose} || 99,
        '-sections' => '(?i:(Usage|Options))',
        '-exitval'  => 0,
    );
    return;
}

sub Configure {
    my @config = @_;
    $ALLOW_PRESET_OVERRIDE = scalar grep { $_ eq 'allow_preset_override' } @_;
    return Getopt::Long::Configure( grep { $_ ne 'allow_preset_override' } @_ );
}

sub _clean_options {
    my ( $opts ) = @_;
    for my $option ( keys %$opts ) {
        delete $opts->{$option} unless defined $opts->{$option}
    }
    return;
}

sub _print_version {
    my $script = basename($0);
    my $version = $main::VERSION ? ( 'v' . $main::VERSION ) : '(unknown version)';
    print "$script $version\n";
    exit 1;
}

sub _merge_config_file_options {
    my $config_file = _default_config();
    if ( -e $config_file && open( my $fh, '<', $config_file ) ) {
        my @options = ();
        while ( my $line = <$fh> ) {
            $line =~ s/\#.+$//;
            $line =~ s/^\s+//;
            $line =~ s/\s+$//;
            next unless $line;
            push @options, split( /\s+/, $line );
        }
        close $fh;
        unshift @ARGV, @options;
    }
}

sub _default_config {
    my $script = basename($0);
    $script =~ s/\.pl$//;
    require File::HomeDir && return File::HomeDir->my_home . '/.' . $script . 'rc';
    warn q|Can't load File::HomeDir|;
    return;
}

sub _filter_options {
    my ( $opts, $option_args ) = @_;
    my $getopt_long_options = {};

    my $found_presets = {};
    my $illegal_preset_count = 0;
    for my $opt (@$option_args) {
        my ( $option_lookup, $hash_key ) = _cleanup_options($opt);
        for my $option ( keys %$option_lookup ) {
            if ( $PRESET_OPTIONS->{$option} && !$ALLOW_PRESET_OVERRIDE) {
                print "By default, you may not override preset option '$option'\n"
                    . "To enable preset overriding use \"Configure( 'allow_preset_override' );\"\n";
                $illegal_preset_count++;
                next;
            }
            elsif ( $PRESET_OPTIONS->{$option} ) {
                $found_presets->{ $PRESET_OPTIONS->{$option} }++;
            }
            $getopt_long_options->{$opt} = \$opts->{$hash_key};
        }
    }

    if ( $illegal_preset_count ) {
        print "\n";
        exit;
    }

    $getopt_long_options->{'h|help'} = sub { Usage( verbose => 0 ) }
        unless $found_presets->{help};
    $getopt_long_options->{'H|man'} = sub { Usage( verbose => 2 ) }
        unless $found_presets->{man};
    $getopt_long_options->{'v|verbose+'} = \$opts->{verbose} unless $found_presets->{verbose};
    $getopt_long_options->{'version'}    = \$opts->{version} unless $found_presets->{version};

    return %$getopt_long_options;
}

sub _cleanup_options {
    my ( $opt ) = @_;
    my $option_lookup = {};
    my ( $option, @modifier ) = split( /([\!\+\=\:])/, $opt );
    my $modifier = join( '', grep { $_ }  @modifier );

    if ( length( $option ) == 1 ) {
        print "Short option definition '$option' is invalid.\n"
            . "A descriptive long option is required when defining short option (ie 'h|help')\n\n";
        exit;
    }

    my @alt_options = split /\|/, $option;
    $option_lookup->{$_} = 1 for @alt_options;

    return ( $option_lookup, _determine_key( \@alt_options ) );
}

sub _determine_key {
    my ( $alt_options ) = @_;
    my @keys = sort { length($b) <=> length($a) } @$alt_options;
    my $key = $keys[0];
    $key =~ s/\-/\_/g;
    return $key;
}

1;

__END__