File Coverage

blib/lib/Win32/ShellQuote.pm

Criterion	Covered	Total	%
statement	12	42	28.5
branch	0	12	0.0
condition	0	6	0.0
subroutine	4	13	30.7
pod	8	8	100.0
total	24	81	29.6

package Win32::ShellQuote;
use strict;
use warnings FATAL => 'all';
use base 'Exporter';
use Carp;

our $VERSION = '0.002003';
$VERSION = eval $VERSION;

our @EXPORT_OK = qw(
    quote_native
    quote_cmd
    quote_system_list
    quote_system_string
    quote_system
    quote_system_cmd
    quote_literal
    cmd_escape
);
our %EXPORT_TAGS = (all => [@EXPORT_OK]);

sub quote_native {
    return join q{ }, quote_system_list(@_);
}

sub quote_cmd {
    return cmd_escape(quote_native(@_));
}

sub quote_system_list {
    # have to force quoting, or perl might try to use cmd anyway
    return map { quote_literal($_, 1) } @_;
}

sub quote_system_string {
    my $args = quote_native(@_);

    if (_has_shell_metachars($args)) {
        $args = cmd_escape($args);
    }
    return $args;
}

sub quote_system {
    if (@_ > 1) {
        return quote_system_list(@_);
    }
    else {
        return quote_system_string(@_);
    }
}

sub quote_system_cmd {
    # force cmd, even when running through system
    my $args = quote_native(@_);

    if (! _has_shell_metachars($args)) {
        # IT BURNS LOOK AWAY
        return '%PATH:~0,0%' . cmd_escape($args);
    }
    return cmd_escape($args);
}


sub cmd_escape {
    my $string = shift;
    if ($string =~ /[\r\n\0]/) {
        croak "can't quote newlines to pass through cmd.exe";
    }
    $string =~ s/([()%!^"<>&|])/^$1/g;
    return $string;
}

sub quote_literal {
    my ($text, $force) = @_;

    # basic argument quoting.  uses backslashes and quotes to escape
    # everything.
    if (!$force && $text ne '' && $text !~ /[ \t\n\x0b"]/) {
        # no quoting needed
    }
    else {
        $text =~ s{(\\*)(?="|\z)}{$1$1}g;
        $text =~ s{"}{\\"}g;
        $text = qq{"$text"};
    }

    return $text;
}

# derived from rules in code in win32.c
sub _has_shell_metachars {
    my $string = shift;

    return 1
        if $string =~ /%/;
    $string =~ s/(['"]).*?(\1|\z)//;
    return $string =~ /[<>|]/;
}

1;

__END__