File Coverage

blib/lib/Getopt/LongUsage.pm

Criterion	Covered	Total	%
statement	169	179	94.4
branch	70	90	77.7
condition	34	72	47.2
subroutine	16	16	100.0
pod	3	3	100.0
total	292	360	81.1

package Getopt::LongUsage;

use 5.008001;
use strict;
use warnings;
use Exporter;
use Carp;
use Getopt::Long 2.37;
use Data::Dumper;

BEGIN {
    use vars      qw(@ISA @EXPORT @EXPORT_OK);
    @ISA        = qw(Exporter);
    @EXPORT     = qw(&GetLongUsage);
    @EXPORT_OK  = qw(&GetLongUsage);

    use vars      qw($REF_NAME);
    $REF_NAME   = "Getopt::LongUsage";  # package name

    use vars      qw( $VERSION );
    $VERSION    = '0.12';
}


# new
sub new {
    my $pkg	= shift;
    my $class	= ref($pkg) || $pkg;
    my $self	= bless {}, $class;
    return $self;
}


sub ParseGetoptLongConfig (@) {
    my $self    = shift if ref($_[0]) eq $REF_NAME || undef;
    my @optionlist  = @_;
    my $opctl   = {};
    my $error   = '';

    # Since we are reading a configuration for Getopt::Long, we have to do some
    # of the same things as that module, however we do not need all the same
    # resulting information, so we will shift the unneeded stuff into oblivion

    # from Getopt::Long
    # Check for ref HASH as first argument.
    # First argument may be an object.
    if ( @optionlist &&
         ref($optionlist[0]) &&
         UNIVERSAL::isa($optionlist[0],'HASH') ) {
        shift @optionlist;
    }

    # from Getopt::Long
    # See if the first element of the optionlist contains option
    # starter characters.
    # Be careful not to interpret '<>' as option starters.
    # for Getopt::LongUsage
    # This is where Getopt::Long defined the $prefix as a regex
    if ( @optionlist &&
         $optionlist[0] =~ /^\W+$/ &&
	     !( $optionlist[0] eq '<>' &&
	        @optionlist > 0 &&
	        ref($optionlist[1])) ) {
        shift (@optionlist);
    }

    # from Getopt::Long
    # Verify correctness of optionlist.
    while (@optionlist) {
        my $opt = shift (@optionlist);

        unless ( defined $opt ) {
            $error .= "Undefined argument in option spec\n";
            next;
        }

        # from Getopt::Long
        # Strip leading prefix so people can specify "--foo=i" if they like.
        # $opt = $+ if $opt =~ /^$prefix+(.*)$/s;
        # for Getopt::LongUsage
        # We are not honoring $prefix in the configuration option list.
        # the option list should not contain prefixes, just the option name
        # i.e., configure with 'debug|d:i' and not '--debug|-d:i'
        # I guess it could be added in if requested
        # This is the globally Getopt::Long configured $prefix value

        # from Getopt::Long
        # Parse option spec.
        my ($name, $orig) = Getopt::Long::ParseOptionSpec($opt,$opctl);
        unless ( defined $name ) {
            # Failed. $orig contains the error message. Sorry for the abuse.
            $error .= $orig;
        }
        shift (@optionlist) if @optionlist && ref($optionlist[0]);
    }
    return $opctl;
}


# GetLongUsage
#
# TODO - add support for 'cols' property
#=item * cols
#
#The number of columns the output should be formatted for. Text will be wrapped
#around in order to stay within this column boundry.
#The default is C<0> (zero), which is no defined column width.
#
sub GetLongUsage (@) {
    my $self    = shift if ref($_[0]) eq $REF_NAME || undef;
    my %args    = @_;
    my %format          = @{$args{'format'}} if exists $args{'format'};

    # Setup the description map
    # my %descriptions    = @{$args{'descriptions'}} if exists $args{'descriptions'};
    # We have to do it this alternate way, otherwise perl will throw an error if
    # any key is undef. We do not care if the value is undef.
    my %descriptions;
    if (exists $args{'descriptions'}) {
        my @temp_desc = @{$args{'descriptions'}}; # make a copy
        while (@temp_desc) {
            my $k = shift @temp_desc;
            my $v = shift @temp_desc;
            next if ! defined $k || $k eq "";
            $descriptions{$k} = $v;
        }
    }
    #DEBUG# print Dumper {"descriptions", \%descriptions};

    # Some private methods
    # &$elementexists()
    # return true if a value (element) exists in a given array ref
    my $elementexists = sub {
        my $element = shift;
        my $array = shift;
        foreach my $a (@$array) {
            return 1 if lc $element eq lc $a;
        }
        return 0;
    };
    # &$gethashvalue()
    # return the value of a given key in a hash ref, case insensitive
    my $gethashvalue = sub {
        my $key = shift;
        my $hash = shift;
        return $hash->{$key} if exists $hash->{$key};
        foreach my $hk (keys %$hash) {
            if (lc $key eq lc $hk) {
                return $hash->{$hk};
            }
        }
        return undef;
    };
    # End private methods

    # These are defined constants inside Getopt::Long, as of version 2.38
    # If these constants change inside Getopt::Long, this module will break.
    my %m = (   CTL_TYPE    => $Getopt::Long::CTL_TYPE       || 0,
                CTL_CNAME   => $Getopt::Long::CTL_CNAME      || 1,
                CTL_DEFAULT => $Getopt::Long::CTL_DEFAULT    || 2,
                CTL_DEST    => $Getopt::Long::CTL_DEST       || 3,
                CTL_DEST_SCALAR => $Getopt::Long::CTL_DEST_SCALAR    || 0,
                CTL_DEST_ARRAY  => $Getopt::Long::CTL_DEST_ARRAY     || 1,
                CTL_DEST_HASH   => $Getopt::Long::CTL_DEST_HASH      || 2,
                CTL_DEST_CODE   => $Getopt::Long::CTL_DEST_CODE      || 3,
                CTL_AMIN    => $Getopt::Long::CTL_AMIN       || 4,
                CTL_AMAX    => $Getopt::Long::CTL_AMAX       || 5
            );

    # Retrieve the Getopt::Long config map resulting from parsing the options
    if (! exists $args{'Getopt_Long'}) { warn "GetLongUsage(): Argument Getopt_Long is required."; return undef; }
    my $optionmap = ParseGetoptLongConfig(@{$args{'Getopt_Long'}});
    #DEBUG# print Dumper {"optionmap", $optionmap};

    # Create the map for the user preferred order of displaying the options.
    my $ordermap = {};  # This is the map
    my $orderindex = 0; # we'll use this one later, keeping the last value, when populating '@output'
    my $tmp_ordernumber = 0;
    if ((exists $args{'descriptions'}) && (ref($args{'descriptions'}) eq "ARRAY")) {
    while ($tmp_ordernumber < scalar @{$args{'descriptions'}}) {
        if ($elementexists->($args{'descriptions'}->[$tmp_ordernumber],$args{'hidden_opts'})) {
            $tmp_ordernumber += 2;
            next;
        }
        if (!exists $optionmap->{ lc $args{'descriptions'}->[$tmp_ordernumber] }) {
            carp ("Item \"".$args{'descriptions'}->[$tmp_ordernumber]."\" in descriptions argument is not defined as an option in Getopt_Long argument.");
        } else {
            unless ((! defined $args{'descriptions'}->[$tmp_ordernumber]) || ($args{'descriptions'}->[$tmp_ordernumber] eq "")) {
                $ordermap->{ $optionmap->{ lc $args{'descriptions'}->[$tmp_ordernumber] }[$m{'CTL_CNAME'}] } = $orderindex;
            }
            $orderindex++;
        }
        $tmp_ordernumber += 2;
    }
    #DEBUG# print Dumper {"ordermap", $ordermap};
    }

    # Create the usage message map for the options;
    my $usagemap = {};  # This is the map
    foreach my $opt (keys %$optionmap) {
        next if !defined $opt || $opt eq "";
        my $ctlname = $optionmap->{$opt}[$m{CTL_CNAME}];
        next if !defined $ctlname;
        unless (exists $usagemap->{ $ctlname }) {
            $usagemap->{ $ctlname } = [[],[]]; # [[alias1,alias2],[descline1,descline2]]
        }
        unless (lc $opt eq lc $ctlname) {
            push (@{$usagemap->{ $ctlname }[0]},$opt)
        }
        if ((@{$usagemap->{ $ctlname }[1]} == 0) && (my $desc = $gethashvalue->($opt,\%descriptions))) {
            my @lines = split("\n", $desc);
            $usagemap->{ $ctlname }[1] = \@lines;
        }
    }
    #DEBUG# print Dumper {"usagemap",$usagemap};

    # Format the text usage message for the options
    # Getopt::Long defines 'longprefix = "(--)"' in ConfigDefaults() as the
    # variable $Getopt::Long::longprefix, but does not define any "shortprefix"
    # At this time, instead of trying to figure this out, we will just use the
    # default assumed short and long prefixes.
    # It can be changed later if I get a request to do so, with suggestions on
    # how it can be accomplished.
    # For now, I will allow it as a formatting option.
    my $longprefix  = defined $format{'longprefix'} ? $format{'longprefix'} : "--";
    my $shortprefix = defined $format{'shortprefix'} ? $format{'shortprefix'} : "-";
    my $cols        = defined $format{'cols'} ? $format{'cols'} : 0;
    my $tab         = defined $format{'tab'} ? $format{'tab'} : 2;
    my $indent      = defined $format{'indent'} ? $format{'indent'} : 0;
    # Short options are assumed to be those which are only a single character
    # I do not see how options are specially identified as short in Getopt::Long
    # as it appears that both '--h' and '-h' are acceptable input
    # Short options go first, then the main long option, then aliases
    my @output; # ([[opt column],[desc column]], [[],[]], etc...);
    my $maxoptwidth = 0;
    foreach my $optname (keys %$usagemap) {
        my (@shortopt, $mainopt, @aliasopt);
        unless ($elementexists->($optname,$args{'hidden_opts'})) {
            if (length($optname) == 1) {
                push (@shortopt, ($shortprefix . $optname));
            } else {
                $mainopt = ($longprefix . $optname);
            }
        }
        foreach my $opt (@{$usagemap->{$optname}[0]}) {
            next unless defined $opt;
            next if lc $opt eq lc $optname;
            if (length($opt) == 1) {
                push (@shortopt, ($shortprefix . $opt)) unless $elementexists->($opt,$args{'hidden_opts'});
                next;
            }
            push(@aliasopt,($longprefix . $opt)) unless $elementexists->($opt,$args{'hidden_opts'});
        }
        next if @shortopt == 0 && !defined $mainopt && @aliasopt == 0;
        my @opttext;
        push (@opttext, @shortopt) if @shortopt > 0;
        push (@opttext, $mainopt) if defined $mainopt;
        push (@opttext, @aliasopt) if @aliasopt > 0;
        my $opttext = join(', ',@opttext);
        $maxoptwidth = length($opttext) if length($opttext) > $maxoptwidth;
        #push (@output, [ [$opttext], $usagemap->{$optname}[1] ] );
        my $tmp_ordernumber;
        if (exists $ordermap->{ $optname }) {
            $tmp_ordernumber = $ordermap->{ $optname };
        } else {
            $tmp_ordernumber = $orderindex;
            $orderindex++;
        }
        $output[$tmp_ordernumber] = [ [$opttext], $usagemap->{$optname}[1] ];
    }
    #DEBUG# print Dumper ("output",@output);

    # Assemble the usage text message
    my @usage;
    push (@usage, split("/$/",$args{'header'})) if defined $args{'header'};
    push (@usage, split("/$/",$args{'cli_use'})) if defined $args{'cli_use'};
    my $opttext;
    foreach my $outline (@output) {
        $opttext .= " "x$tab;
        if ((! defined $outline) || (ref $outline !~ /ARRAY/) || (! defined $outline->[0][0])) {
            $opttext .= " "x$maxoptwidth;
            $opttext .= " "x$tab;
        } else {
            $opttext .= $outline->[0][0];
            $opttext .= " "x($maxoptwidth - length($outline->[0][0]));
            $opttext .= " "x$tab;
            $opttext .= join(("\n"." "x($tab + $maxoptwidth + $tab)),@{$outline->[1]});
        }
        $opttext .= "\n";
    }
    chomp ($opttext);
    push (@usage, $opttext);
    push (@usage, split("/$/",$args{'footer'})) if defined $args{'footer'};
    my $usage;
    foreach my $line (@usage) {
        $usage .= " "x$indent;
        $line =~ s/\n/("\n"." "x$indent)/eg;
        $usage .= $line;
        $usage .= "\n";
    }

    # Return the usage text message to the caller
    return $usage;
}


1;
__END__