File Coverage

blib/lib/Getopt/Mixed.pm

Criterion	Covered	Total	%
statement	97	128	75.7
branch	45	92	48.9
condition	11	32	34.3
subroutine	9	12	75.0
pod	0	8	0.0
total	162	272	59.5

#---------------------------------------------------------------------
package Getopt::Mixed;
#
# Copyright 1995 Christopher J. Madsen
#
# Author: Christopher J. Madsen
# Created: 1 Jan 1995
#
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See either the
# GNU General Public License or the Artistic License for more details.
#
# ABSTRACT: [OBSOLETE] getopt processing with both long and short options
#---------------------------------------------------------------------

require 5.000;
use strict;
use Carp;

use vars qw(
    @EXPORT @EXPORT_OK @ISA %options
    $PERMUTE $REQUIRE_ORDER $RETURN_IN_ORDER $VERSION
    $badOption $checkArg $checkType $floatRegexp $group $ignoreCase
    $intRegexp $option $optionEnd $optionStart $order $typeChars
);

require Exporter;
@ISA = qw(Exporter);
@EXPORT = ();
@EXPORT_OK = qw(abortMsg getOptions nextOption);

#=====================================================================
# Package Global Variables:

BEGIN
{
    $VERSION = '1.12';

    # The permissible settings for $order:
    $REQUIRE_ORDER   = 0;
    $PERMUTE         = 1;
    $RETURN_IN_ORDER = 2;

    # Regular expressions:
    $intRegexp   = '^[-+]?\d+$';               # Match an integer
    $floatRegexp = '^[-+]?(\d*\.?\d+|\d+\.)$'; # Match a real number
    $typeChars   = 'sif';                      # Match type characters
} # end BEGIN

#=====================================================================
# Subroutines:
#---------------------------------------------------------------------
# Initialize the option processor:
#
# You should set any customization variables *after* calling init.
#
# For a description of option declarations, see the documentation at
# the end of this file.
#
# Input:
#   List of option declarations (separated by whitespace)
#     If the first argument is entirely non-alphanumeric characters
#     with no whitespace, it is the characters that start options.

sub init
{
    undef %options;
    my($opt,$type);

    $ignoreCase  = 1;           # Ignore case by default
    $optionStart = "-";         # Dash is the default option starter

    # If the first argument is entirely non-alphanumeric characters
    # with no whitespace, it is the desired value for $optionStart:
    $optionStart = shift @_ if $_[0] =~ /^[^a-z0-9\s]+$/i;

    foreach $group (@_) {
        # Ignore case unless there are upper-case options:
        $ignoreCase = 0 if $group =~ /[A-Z]/;
        foreach $option (split(/\s+/,$group)) {
            croak "Invalid option declaration `$option'"
                unless $option =~ /^([^=:>]+)([=:][$typeChars]|>[^=:>]+)?$/o;
            $opt  = $1;
            $type = $2 || "";
            if ($type =~ /^>(.*)$/) {
                $type = $1;
                croak "Invalid synonym `$option'"
                    if (not defined $options{$type}
                        or $options{$type} =~ /^[^:=]/);
            } # end if synonym
            $options{$opt} = $type;
        } # end foreach option
    } # end foreach group

    # Handle POSIX compliancy:
    if (defined $ENV{"POSIXLY_CORRECT"}) {
        $order = $REQUIRE_ORDER;
    } else {
        $order = $PERMUTE;
    }

    $optionEnd = 0;
    $badOption = \&badOption;
    $checkArg  = \&checkArg;
} # end init

#---------------------------------------------------------------------
# Clean up when we're done:
#
# This just releases the memory used by the %options hash.
#
# If 'help' was defined as an option, a new hash with just 'help' is
# created, in case the program calls abortMsg.

sub cleanup
{
    my $help = defined($options{'help'});
    undef %options;
    $options{'help'} = "" if $help;
} # end cleanup

#---------------------------------------------------------------------
# Abort program with message:
#
# Prints program name and arguments to STDERR
# If --help is an option, prints message saying 'Try --help'
# Exits with code 1

sub abortMsg
{
    my $name = $0;
    $name =~ s|^.+[\\/]||;      # Remove any directories from name
    print STDERR $name,": ",@_,"\n";
    print STDERR "Try `$name --help' for more information.\n"
        if defined $options{"help"};
    exit 1;
} # end abortMsg

#---------------------------------------------------------------------
# Standard function for handling bad options:
#
# Prints an error message and exits.
#
# You can override this by setting $Getopt::Mixed::badOption to a
# function reference.
#
# Input:
#   Index into @ARGV
#   The option that caused the error
#   An optional string describing the problem
#     Currently, this can be
#       undef        The option was not recognized
#       'ambiguous'  The option could match several long options
#
# Note:
#   The option has already been removed from @ARGV.  To put it back,
#   you can say:
#     splice(@ARGV,$_[0],0,$_[1]);
#
#   If your function returns, it should return whatever you want
#   nextOption to return.

sub badOption
{
    my ($index, $option, $problem) = @_;

    $problem = 'unrecognized' unless $problem;

    abortMsg("$problem option `$option'");
} # end badOption

#---------------------------------------------------------------------
# Make sure we have the proper argument for this option:
#
# You can override this by setting $Getopt::Mixed::checkArg to a
# function reference.
#
# Input:
#   $i:       Position of argument in @ARGV
#   $value:   The text appended to the option (undef if no text)
#   $option:  The pretty name of the option (as the user typed it)
#   $type:    The type of the option
#
# Returns:
#   The value of the option's argument

sub checkArg
{
    my ($i,$value,$option,$type) = @_;

    abortMsg("option `$option' does not take an argument")
        if (not $type and defined $value);

    if ($type =~ /^=/) {
        # An argument is required for this option:
        $value = splice(@ARGV,$i,1) unless defined $value;
        abortMsg("option `$option' requires an argument")
            unless defined $value;
    }

    if ($type =~ /i$/) {
        abortMsg("option `$option' requires integer argument")
            if (defined $value and $value !~ /$intRegexp/o);
    }
    elsif ($type =~ /f$/) {
        abortMsg("option `$option' requires numeric argument")
            if (defined $value and $value !~ /$floatRegexp/o);
    }
    elsif ($type =~ /^[=:]/ and ref($checkType)) {
        $value = &$checkType($i,$value,$option,$type);
    }

    $value = "" if not defined $value and $type =~ /^:/;

    $value;
} # end checkArg

#---------------------------------------------------------------------
# Find a match for an incomplete long option:
#
# Input:
#   The option text to match
#
# Returns:
#   The option that matched, or
#   undef, if no option matched, or
#   (undef, 'ambiguous'), if multiple options matched

sub findMatch
{
    my $opt = shift;

    $opt =~ s/-/[^-]*-/g;
    $opt .= ".*";

    my @matches = grep(/^$opt$/, keys %options);

    return undef       if $#matches <  0;
    return $matches[0] if $#matches == 0;

    $opt = $matches[0];
    $opt = $options{$opt} if $options{$opt} =~ /^[^=:]/;

    foreach (@matches) {
        return (undef, 'ambiguous')
            unless $_ eq $opt or $options{$_} eq $opt;
    }

    $opt;
} # end findMatch

#---------------------------------------------------------------------
# Return the next option:
#
# Returns a list of 3 elements:  (OPTION, VALUE, PRETTYNAME), where
#   OPTION is the name of the option,
#   VALUE is its argument, and
#   PRETTYNAME is the option as the user entered it.
# Returns the null list if there are no more options to process
#
# If $order is $RETURN_IN_ORDER, and this is a normal argument (not an
# option), OPTION will be the null string, VALUE will be the argument,
# and PRETTYNAME will be undefined.

sub nextOption
{
    return () if $#ARGV < 0;    # No more arguments

    if ($optionEnd) {
        # We aren't processing any more options:
        return ("", shift @ARGV) if $order == $RETURN_IN_ORDER;
        return ();
    }

    # Find the next option:
    my $i = 0;
    while (length($ARGV[$i]) < 2 or
           index($optionStart,substr($ARGV[$i],0,1)) < 0) {
        return ()                if $order == $REQUIRE_ORDER;
        return ("", shift @ARGV) if $order == $RETURN_IN_ORDER;
        ++$i;
        return () if $i > $#ARGV;
    } # end while

    # Process the option:
    my($option,$opt,$value,$optType,$prettyOpt);
    $option = $ARGV[$i];
    if (substr($option,0,1) eq substr($option,1,1)) {
        # If the option start character is repeated, it's a long option:
        splice @ARGV,$i,1;
        if (length($option) == 2) {
            # A double dash by itself marks the end of the options:
            $optionEnd = 1;     # Don't process any more options
            return nextOption();
        } # end if bare double dash
        $opt = substr($option,2);
        if ($opt =~ /^([^=]+)=(.*)$/) {
            $opt = $1;
            $value = $2;
        } # end if option is followed by value
        $opt =~ tr/A-Z/a-z/ if $ignoreCase;
        $prettyOpt = substr($option,0,2) . $opt;
        my $problem;
        ($opt, $problem) = findMatch($opt)
            unless defined $options{$opt} and length($opt) > 1;
        return &$badOption($i,$option,$problem) unless $opt;
        $optType = $options{$opt};
        if ($optType =~ /^[^:=]/) {
            $opt = $optType;
            $optType = $options{$opt};
        }
        $value = &$checkArg($i,$value,$prettyOpt,$optType);
    } # end if long option
    else {
        # It's a short option:
        $opt = substr($option,1,1);
        $opt =~ tr/A-Z/a-z/ if $ignoreCase;
        return &$badOption($i,$option) unless defined $options{$opt};
        $optType = $options{$opt};
        if ($optType =~ /^[^:=]/) {
            $opt = $optType;
            $optType = $options{$opt};
        }
        if (length($option) == 2 or $optType) {
            # This is the last option in the group, so remove the group:
            splice(@ARGV,$i,1);
        } else {
            # Just remove this option from the group:
            substr($ARGV[$i],1,1) = "";
        }
        if ($optType) {
            $value = (length($option) > 2) ? substr($option,2) : undef;
            $value =~ s/^=// if $value; # Allow either -d3 or -d=3
        } # end if option takes an argument
        $prettyOpt = substr($option,0,2);
        $value = &$checkArg($i,$value,$prettyOpt,$optType);
    } # end else short option
    ($opt,$value,$prettyOpt);
} # end nextOption

#---------------------------------------------------------------------
# Get options:
#
# Input:
#   The same as for init()
#   If no parameters are supplied, init() is NOT called.  This allows
#   you to call init() yourself and then change the configuration
#   variables.
#
# Output Variables:
#   Sets $opt_X for each `-X' option encountered.
#
#   Note that if --apple is a synonym for -a, then --apple will cause
#   $opt_a to be set, not $opt_apple.

sub getOptions
{
    &init if $#_ >= 0;        # Pass arguments (if any) on to init

    # If you want to use $RETURN_IN_ORDER, you have to call
    # nextOption yourself; getOptions doesn't support it:
    $order = $PERMUTE if $order == $RETURN_IN_ORDER;

    my ($option,$value,$package);

    $package = (caller)[0];

    while (($option, $value) = nextOption()) {
        $option =~ s/\W/_/g;    # Make a legal Perl identifier
        $value = 1 unless defined $value;
        my $code = "\$" . $package . "::opt_$option = \$value;";
        $code =~ /(.+)/;        # Untaint it
        eval $1;
    } # end while

    cleanup();
} # end getOptions

#=====================================================================
# Package return value:

$VERSION;

__END__