view release on metacpan or  search on metacpan

Argv.pm  view on Meta::CPAN

# Getopt::Long::GetOptions() respects '--' but strips it, while
# we want to respect '--' and leave it in. Thus this override.
sub GetOptions {
    @ARGV = map {/^--$/ ? qw(=--= --) : $_} @ARGV;
    my $ret = Getopt::Long::GetOptions(@_);
    @ARGV = map {/^=--=$/ ? qw(--) : $_} @ARGV;
    return $ret;
}

# This method is much like the generated exec methods but has some
# special-case logic: If called with a param which is true, it starts up
# a coprocess. If called with false (aka 0) it shuts down the coprocess
# and destroys the IPC::ChildSafe object. If called with no params at
# all it returns the existing IPC::ChildSafe object.
sub ipc_childsafe {
    my $self = shift;
    my $ipc_state = $_[0];
    my $ipc_obj;
    if ($ipc_state) {
	eval { require IPC::ChildSafe };
	return undef if $@;
	IPC::ChildSafe->VERSION(3.10);
	$ipc_obj = IPC::ChildSafe->new(@_);
    }
    no strict 'refs';
    if (ref $self) {
	if (defined $ipc_state) {
	    $self->{_IPC_CHILDSAFE} = $ipc_obj;
	    return $self;
	} else {
	    return exists($self->{_IPC_CHILDSAFE}) ?
			$self->{_IPC_CHILDSAFE} : $class->{_IPC_CHILDSAFE};
	}
    } else {
	if (defined $ipc_state) {
	    $class->{_IPC_CHILDSAFE} = $ipc_obj;
	    return $self;
	} else {
	    return $class->{_IPC_CHILDSAFE};
	}
    }
}

# Class/instance method. Parses command line for e.g. -/dbg=1. See PODs.
sub attropts {
    my $self = shift;
    my $r_argv = undef;
    my $prefix = '-/';
    if (ref $_[0] eq 'HASH') {
	my $cfg = shift;
	$r_argv = $cfg->{ARGV};
	$prefix = $cfg->{PREFIX};
    }
    require Getopt::Long;
    local $Getopt::Long::passthrough = 1;
    local $Getopt::Long::genprefix = "($prefix)";
    my @flags = map {"$_=i"} ((map lc, keys %Argv::Argv), @_);
    my %opt;
    if (ref $self) {
	if ($r_argv) {
	    local @ARGV = @$r_argv;
	    GetOptions(\%opt, @flags);
	    @$r_argv = @ARGV;
	} else {
	    local @ARGV = $self->args;
	    if (@ARGV) {
		GetOptions(\%opt, @flags);
		$self->args(@ARGV);
	    }
	}
    } elsif ($r_argv) {
	local @ARGV = @$r_argv;
	GetOptions(\%opt, @flags);
	@$r_argv = @ARGV;
    } elsif (@ARGV) {
	GetOptions(\%opt, @flags);
    }
    for my $method (keys %opt) {
	$self->$method($opt{$method});
    }
    return $self;
}
*stdopts = \&attropts;	# backward compatibility

# A class method which returns a summary of operations performed in
# printable format. Called with a void context to start data-
# collection, with a scalar context to end it and get the report.
sub summary {
    my $cls = shift;
    my($cmds, $operands);
    if (!defined wantarray) {
	$Argv::Summary = {};
	return;
    }
    return unless $Argv::Summary;
    my $fmt = "%30s:  %4s\t%s\n";
    my $str = sprintf $fmt, "$cls Summary", 'Cmds', 'Operands';
    for (sort keys %{$Argv::Summary}) {
	my @stats = @{$Argv::Summary->{$_}};
	$cmds += $stats[0];
	$operands += $stats[1];
	$str .= sprintf $fmt, $_, $stats[0], $stats[1];
    }
    $str .= sprintf $fmt, 'TOTAL', $cmds, $operands if defined $cmds;
    $Argv::Summary = 0;
    return $str;
}

# Constructor.
sub new {
    my $proto = shift;
    my $attrs = shift if ref($_[0]) eq 'HASH';
    my $self;
    if (ref($proto)) {
	# As an instance method, make a deep clone of the invoking object.
	# Some cloners are fast but not commonly installed, others the
	# reverse. We try them in order of speed and fall back to
	# Data::Dumper which is slow but core Perl as of 5.6.0. I could
	# just inherit from Clone or Storable but want to not force
	# users who don't need cloning to install them.
	eval {
	    require Clone;
	    Clone->VERSION(0.12);       # 0.11 has a bug that breaks Argv
	    $self = Clone::clone($proto);
	};
	if ($@) {
	    eval {
		require Storable;
		$self = Storable::dclone($proto);
	    };
	}
	if ($@) {

Argv.pm  view on Meta::CPAN

	next if defined $self->{AV_OPTS}{$set};
	$self->{AV_OPTS}{$set} = [];
	$self->{AV_LKG}{$set} = {};
	my($p_meth, $o_meth, $f_meth) = map { $_ . $set } qw(parse opts flag);
	$self->{AV_DESC}{$set} = [];
	no strict 'refs'; # needed to muck with symbol table
	*$p_meth = sub {
	    my $self = shift;
	    $self->{AV_DESC}{$set} ||= [];
	    if (@_) {
		if (ref($_[0]) eq 'ARRAY') {
		    $self->{CFG}{$set} = shift;
		} elsif (ref($_[0]) eq 'HASH') {
		    $self->warning("do not provide a linkage specifier");
		    shift;
		}
		@{$self->{AV_DESC}{$set}} = @_;
		$self->factor($set,
				$self->{AV_DESC}{$set}, $self->{AV_OPTS}{$set},
				$self->{AV_ARGS}, $self->{CFG}{$set});
		if (defined $self->{AV_OPTS}{$set}) {
		    my @parsedout = @{$self->{AV_OPTS}{$set}};
		}
	    }
	    return @{$self->{AV_OPTS}{$set}};
	} unless $Argv::{$p_meth};
	*$o_meth = sub {
	    my $self = shift;
	    $self->{AV_OPTS}{$set} ||= [];
	    if (@_ || !defined(wantarray)) {
		@{$self->{AV_OPTS}{$set}} = @_;
	    }
	    return @_ ? $self : @{$self->{AV_OPTS}{$set}};
	} unless $Argv::{$o_meth};
	*$f_meth = sub {
	    my $self = shift;
	    if (@_ > 1) {
		while(my($key, $val) = splice(@_, 0, 2)) {
		    $self->{AV_LKG}{$set}{$key} = $val;
		}
	    } else {
		my $key = shift;
		return $self->{AV_LKG}{$set}{$key};
	    }
	} unless $Argv::{$f_meth};
    }
    return keys %{$self->{AV_DESC}}; # this is the set of known optsets.
}

# Not generally used except internally; not documented. First arg
# is an option set name followed by bunch of array-refs: a pointer
# to a list of Getopt::Long-style option descs, a ref to be filled
# in with a list of found options, another containing the input
# args and to be filled in with the leftovers, and an optional
# one containing Getopt::Long-style config options.
sub factor {
    my $self = shift;
    my($pset, $r_desc, $r_opts, $r_args, $r_cfg) = @_;
    my @vgra;
    {
        local @ARGV = @$r_args;
        if ($r_desc && @$r_desc) {
            require Getopt::Long;
            # Need this version so Configure() returns prev state.
            Getopt::Long->VERSION(2.23);
            if ($r_cfg && @$r_cfg) {
                my $prev = Getopt::Long::Configure(@$r_cfg);
                GetOptions($self->{AV_LKG}{$pset}, @$r_desc);
                Getopt::Long::Configure($prev);
            } else {
                local $Getopt::Long::passthrough = 1;
                local $Getopt::Long::autoabbrev = 1;
                local $Getopt::Long::debug = 1 if $self->dbglevel == 5;
                GetOptions($self->{AV_LKG}{$pset}, @$r_desc);
            }
        }
        @vgra = @ARGV;
    }
    my(@opts, @args);
    for (reverse @$r_args) {
        if (@vgra && $vgra[$#vgra] eq $_) {
            unshift(@args, pop (@vgra));
        } else {
            unshift(@opts, $_);
        }
    }
    @$r_opts = @opts if $r_opts;
    @$r_args = @args;
    return @opts;
}

# Extract and return any of the specified options from object.
sub extract {
    my $self = shift;
    my $set = shift;
    $self->optset($set) unless defined $self->{AV_LKG}{$set};
    my $p_meth = 'parse' . $set;
    my $o_meth = 'opts' . $set;
    $self->$p_meth(@_);
    my @extracts = $self->$o_meth();
    return @extracts;
}

sub argpathnorm {
    my $self = shift;
    my $norm = $self->inpathnorm;
    return unless $norm && !ref($norm);
    if (CYGWIN) { #for the cygwin shell
        s%\\%\\\\%g for @_;
    }
    return unless MSWIN;
    for my $word (@_) {
	# If requested, change / for \ in Windows file paths.
	# This is necessarily an inexact science.
	my @fragments = split ' ', $word;
	for (@fragments) {
	    if (m%^"?/%) {
		if (m%(.*/\w+):(.+)%) {
		    # If it looks like an option specifying a path (/opt:path),
		    # normalize only the path part.
		    my($opt, $path) = ($1, $2);