view release on metacpan or  search on metacpan

Argv.pm  view on Meta::CPAN

	$self->{PIPECB} = $proto->{PIPECB};
    } else {
	$self = {};
	if ($proto ne __PACKAGE__) {
	    # Inherit class attributes from subclass class attributes.
	    no strict 'refs';
	    for (keys %$proto) {
		$self->{$_} = $proto->{$_};
	    }
	}
	$self->{AV_PROG} = [];
	$self->{AV_ARGS} = [];
	$self->{PIPECB} = $Argv{PIPECB};
	bless $self, $proto;
	$self->optset('');
    }
    $self->attrs($attrs) if $attrs;
    $self->argv(@_) if @_;
    return $self;
}
*clone = \&new;

# Nothing to do here, just avoiding interaction with AUTOLOAD.
sub DESTROY { }

sub AUTOLOAD {
    my $self = shift;
    (my $cmd = $Argv::AUTOLOAD) =~ s/.*:://;
    return if $cmd eq 'DESTROY';
    no strict 'refs';
    # install a new method '$cmd' to avoid autoload next time ...
    *$cmd = sub {
	my $self = shift;
	if (ref $self) {
	    $self->argv($cmd, @_);
	} else {
	    $self->new($cmd, @_);
	}
    };
    # ... then service this request
    return $self->$cmd(@_);
}

# Instance methods; most class methods are auto-generated above.

# A shorthand way to set a bunch of attributes by passing a hashref
# of their names=>values.
sub attrs {
    my $self = shift;
    my $attrs = shift;
    if ($attrs) {
	for my $key (keys %$attrs) {
	    (my $method = $key) =~ s/^-//;
	    $self->$method($attrs->{$key});
	}
    }
    return $self;
}

# Replace the instance's prog(), opt(), and args() vectors all together.
# Without arguments, return the command as it currently looks either as
# a list or a string depending on context.
sub argv {
    my $self = shift;
    if (@_) {
	$self->attrs(shift) if ref($_[0]) eq 'HASH';
	$self->{AV_PROG} = [];
	$self->{AV_OPTS}{''} = [];
	$self->{AV_ARGS} = [];
	$self->prog(shift) if @_;
	$self->attrs(shift) if ref($_[0]) eq 'HASH';
	$self->opts(@{shift @_}) if ref $_[0] eq 'ARRAY';
	$self->args(@_) if @_;
	return $self;
    } else {
	my @cmd = ($self->prog, $self->opts, $self->args);
	if (wantarray) {
	    return @cmd;
	} else {
	    return "@cmd";
	}
    }
}
*cmd = \&argv;	# backward compatibility

# Set or get the 'prog' part of the command line.
sub prog {
    my $self = shift;
    if (@_) {
	my @prg = ref $_[0] ? @{$_[0]} : @_;
	@{$self->{AV_PROG}} = @prg;
    } elsif (!defined(wantarray)) {
	@{$self->{AV_PROG}} = ();
    }
    if (@_) {
	return $self;
    } else {
	return wantarray ? @{$self->{AV_PROG}} : ${$self->{AV_PROG}}[0];
    }
}

# Set or get the 'args' part of the command line.
sub args {
    my $self = shift;
    if (@_) {
	my @args = ref $_[0] eq 'ARRAY' ? @{$_[0]} : @_;
	@{$self->{AV_ARGS}} = @args;
    } elsif (!defined(wantarray)) {
	@{$self->{AV_ARGS}} = ();
    }
    if (@_) {
	return $self;
    } else {
	return @{$self->{AV_ARGS}};
    }
}

# Generates the parse(), opts(), and flag() method families. During
# construction this is used to generate the methods for the anonymous
# option set; it can be used explicitly to generate parseXX(), optsXX(),
# and argsXX() for optset 'XX'.

Argv.pm  view on Meta::CPAN

    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);
		    $path =~ s%/%\\%g;
		    $_ = "$opt:$path";
		} else {
		    # If it contains a slash (any kind) after the initial one
		    # treat it as a full path. This is where you get into
		    # ambiguity with combined options (e.g. /E/I/Q/S) which
		    # could technically be a path. So that's just not allowed
		    # when path-norming.
		    my $slashes = tr/\/\\//;
		    s%/%\\%g if $slashes > 1;
		}
	    } else {
		s%/%\\%g;
	    }
	}
	$word = "@fragments";
    }
}

# Quotes @_ in place against shell expansion. Usually called via autoquote attr
sub quote {
    my $self = shift;
    for (grep {defined} @_) {
	# Hack - allow user to exempt any arg from quoting by prefixing '^'.
	next if s%^\^%%;
	# Special case - turn internal newlines back to literal \n on Win32
	s%\n%\\n%gs if MSWIN;
	# If arg is already quoted with '': on Unix it's safe, leave alone.
	# On Windows, replace the single quotes with escaped double quotes.
	if (m%^'(.*)'$%s) {
	    $_ = qq(\\"$1\\") if MSWIN;
	    next;
	} elsif (m%^".*"$%s) {
	    $_ = qq(\\"$_\\") if MSWIN || CYGWIN;
	    next;
	}
	# Skip if contains no special chars.
	if (MSWIN) {
	    # On windows globbing is not handled by the shell so we
	    # let '*' go by.
	    next unless m%[^-=:_."\w\\/*]% || tr%\n%%;
	} else {
	    next unless m%[^-=:_."\w\\/]% || m%\\n% || tr%\n%%;
	}
	# Special case - leave things that look like redirections alone.
	next if /^\d?(?:<{1,2})|(?:>{1,2})/;
	# This is a hack to support MKS-built perl 5.004. Don't know
	# if the problem is with MKS builds or 5.004 per se.
	next if MSWIN && $] < 5.005;
	# Now quote embedded quotes ...
	$_ =~ s%(\\*)"%$1$1\\"%g;
	# quote a trailing \ so it won't quote the quote (!) ...
	s%\\{1}$%\\\\%;
	# and last the entire string.
	$_ = qq("$_");
    }
    return $self;
}