Argv
view release on metacpan or search on metacpan
# 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 ($@) {
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);
( run in 0.236 second using v1.01-cache-2.11-cpan-eab888a1d7d )