view release on metacpan or  search on metacpan

Argv.pm  view on Meta::CPAN

# 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);
		    $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;
}

# Submits @_ to Perl's glob() function. Usually invoked via autoglob attr.
sub glob {
    my $self = shift;
    my @orig = @_ ? @_ : $self->args;
    if (! @orig) {
	$self->warning("no arguments to glob");
	return 0;
    }
    my @globbed;
    for (@orig) {
	if (/^'(.*)'$/) {		# allow '' to escape globbing
	    push(@globbed, $1);
	} elsif (/[*?]/) {
	    push(@globbed, glob)
	} else {
	    push(@globbed, $_)
	}