File Coverage

lib/AppConfig/Args.pm

Criterion	Covered	Total	%
statement	35	42	83.3
branch	11	20	55.0
condition	5	5	100.0
subroutine	5	5	100.0
pod	0	2	0.0
total	56	74	75.6

#============================================================================
#
# AppConfig::Args.pm
#
# Perl5 module to read command line argument and update the variable
# values in an AppConfig::State object accordingly.
#
# Written by Andy Wardley
#
# Copyright (C) 1997-2007 Andy Wardley.  All Rights Reserved.
# Copyright (C) 1997,1998 Canon Research Centre Europe Ltd.
#============================================================================

package AppConfig::Args;
use strict;
use warnings;
use AppConfig::State;
our $VERSION = '1.69';


#------------------------------------------------------------------------
# new($state, \@args)
#
# Module constructor.  The first, mandatory parameter should be a
# reference to an AppConfig::State object to which all actions should
# be applied.  The second parameter may be a reference to a list of
# command line arguments.  This list reference is passed to args() for
# processing.
#
# Returns a reference to a newly created AppConfig::Args object.
#------------------------------------------------------------------------

sub new {
    my $class = shift;
    my $state = shift;


    my $self = {
        STATE    => $state,                # AppConfig::State ref
        DEBUG    => $state->_debug(),      # store local copy of debug
        PEDANTIC => $state->_pedantic,     # and pedantic flags
    };

    bless $self, $class;

    # call parse() to parse any arg list passed
    $self->parse(shift)
        if @_;

    return $self;
}


#------------------------------------------------------------------------
# parse(\@args)
#
# Examines the argument list and updates the contents of the
# AppConfig::State referenced by $self->{ STATE } accordingly.  If
# no argument list is provided then the method defaults to examining
# @ARGV.  The method reports any warning conditions (such as undefined
# variables) by calling $self->{ STATE }->_error() and then continues to
# examine the rest of the list.  If the PEDANTIC option is set in the
# AppConfig::State object, this behaviour is overridden and the method
# returns 0 immediately on any parsing error.
#
# Returns 1 on success or 0 if one or more warnings were raised.
#------------------------------------------------------------------------

sub parse {
    my $self = shift;
    my $argv = shift || \@ARGV;
    my $warnings = 0;
    my ($arg, $nargs, $variable, $value);


    # take a local copy of the state to avoid much hash dereferencing
    my ($state, $debug, $pedantic) = @$self{ qw( STATE DEBUG PEDANTIC ) };

    # loop around arguments
    ARG: while (@$argv && $argv->[0] =~ /^-/) {
        $arg = shift(@$argv);

        # '--' indicates the end of the options
        last if $arg eq '--';

        # strip leading '-';
        ($variable = $arg) =~ s/^-(-)?//;

        # test for '--' prefix and push back any '=value' item
        if (defined $1) {
            ($variable, $value) = split(/=/, $variable);
            unshift(@$argv, $value) if defined $value;
        }

        # check the variable exists
        if ($state->_exists($variable)) {

            # see if it expects any mandatory arguments
            $nargs = $state->_argcount($variable);
            if ($nargs) {
                # check there's another arg and it's not another '-opt'
                if(defined($argv->[0])) {
                    $value = shift(@$argv);
                }
                else {
                    $state->_error("$arg expects an argument");
                    $warnings++;
                    last ARG if $pedantic;
                    next;
                }
            }
            else {
                # set a value of 1 if option doesn't expect an argument
                $value = 1;
            }

            # set the variable with the new value
            $state->set($variable, $value);
        }
        else {
            $state->_error("$arg: invalid option");
            $warnings++;
            last ARG if $pedantic;
        }
    }

    # return status
    return $warnings ? 0 : 1;
}



1;

__END__