view release on metacpan or  search on metacpan

t/roundtrip/test.pl  view on Meta::CPAN

	# so we don't try to put literal newlines and crs onto the
	# command line.
	$args{stdin} =~ s/\n/\\n/g;
	$args{stdin} =~ s/\r/\\r/g;

	if ($is_mswin || $is_netware || $is_vms) {
	    $runperl = qq{$Perl -e "print qq(} .
		$args{stdin} . q{)" | } . $runperl;
	}
	else {
	    $runperl = qq{$Perl -e 'print qq(} .
		$args{stdin} . q{)' | } . $runperl;
	}
    } elsif (exists $args{stdin}) {
        # Using the pipe construction above can cause fun on systems which use
        # ksh as /bin/sh, as ksh does pipes differently (with one less process)
        # With sh, for the command line 'perl -e 'print qq()' | perl -e ...'
        # the sh process forks two children, which use exec to start the two
        # perl processes. The parent shell process persists for the duration of
        # the pipeline, and the second perl process starts with no children.
        # With ksh (and zsh), the shell saves a process by forking a child for
        # just the first perl process, and execing itself to start the second.
        # This means that the second perl process starts with one child which
        # it didn't create. This causes "fun" when if the tests assume that
        # wait (or waitpid) will only return information about processes
        # started within the test.
        # They also cause fun on VMS, where the pipe implementation returns
        # the exit code of the process at the front of the pipeline, not the
        # end. This messes up any test using OPTION FATAL.
        # Hence it's useful to have a way to make STDIN be at eof without
        # needing a pipeline, so that the fork tests have a sane environment
        # without these surprises.

        # /dev/null appears to be surprisingly portable.
        $runperl = $runperl . ($is_mswin ? ' <nul' : ' </dev/null');
    }
    if (defined $args{args}) {
	$runperl = _quote_args($runperl, $args{args});
    }
    if (exists $args{stderr} && $args{stderr} eq 'devnull') {
        $runperl = $runperl . ($is_mswin ? ' 2>nul' : ' 2>/dev/null');
    }
    elsif ($args{stderr}) {
        $runperl = $runperl . ' 2>&1';
    }
    if ($args{verbose}) {
	my $runperldisplay = $runperl;
	$runperldisplay =~ s/\n/\n\#/g;
	_print_stderr "# $runperldisplay\n";
    }
    return $runperl;
}

# sub run_perl {} is alias to below
sub runperl {
    die "test.pl:runperl() does not take a hashref"
	if ref $_[0] and ref $_[0] eq 'HASH';
    my $runperl = &_create_runperl;
    my $result;

    my $tainted = ${^TAINT};
    my %args = @_;
    exists $args{switches} && grep m/^-T$/, @{$args{switches}} and $tainted = $tainted + 1;

    if ($tainted) {
	# We will assume that if you're running under -T, you really mean to
	# run a fresh perl, so we'll brute force launder everything for you
	my $sep;

	if (! eval {require Config; 1}) {
	    warn "test.pl had problems loading Config: $@";
	    $sep = ':';
	} else {
	    $sep = $Config::Config{path_sep};
	}

	my @keys = grep {exists $ENV{$_}} qw(CDPATH IFS ENV BASH_ENV);
	local @ENV{@keys} = ();
	# Untaint, plus take out . and empty string:
	local $ENV{'DCL$PATH'} = $1 if $is_vms && exists($ENV{'DCL$PATH'}) && ($ENV{'DCL$PATH'} =~ /(.*)/s);
	$ENV{PATH} =~ /(.*)/s;
	local $ENV{PATH} =
	    join $sep, grep { $_ ne "" and $_ ne "." and -d $_ and
		($is_mswin or $is_vms or !(stat && (stat _)[2]&0022)) }
		    split quotemeta ($sep), $1;
	if ($is_cygwin) {   # Must have /bin under Cygwin
	    if (length $ENV{PATH}) {
		$ENV{PATH} = $ENV{PATH} . $sep;
	    }
	    $ENV{PATH} = $ENV{PATH} . '/bin';
	}
	$runperl =~ /(.*)/s;
	$runperl = $1;

	$result = `$runperl`;
    } else {
	$result = `$runperl`;
    }
    $result =~ s/\n\n/\n/g if $is_vms; # XXX pipes sometimes double these
    return $result;
}

# Nice alias
*run_perl = *run_perl = \&runperl; # shut up "used only once" warning

sub DIE {
    _print_stderr "# @_\n";
    exit 1;
}

# A somewhat safer version of the sometimes wrong $^X.
sub which_perl {
    unless (defined $Perl) {
	$Perl = $^X;

	# VMS should have 'perl' aliased properly
	return $Perl if $is_vms;

	my $exe;
	if (! eval {require Config; 1}) {
	    warn "test.pl had problems loading Config: $@";
	    $exe = '';
	} else {
	    $exe = $Config::Config{_exe};
	}
       $exe = '' unless defined $exe;

	# This doesn't absolutize the path: beware of future chdirs().
	# We could do File::Spec->abs2rel() but that does getcwd()s,
	# which is a bit heavyweight to do here.

	if ($Perl =~ /^perl\Q$exe\E$/i) {
	    my $perl = "perl$exe";
	    if (! eval {require File::Spec; 1}) {
		warn "test.pl had problems loading File::Spec: $@";
		$Perl = "./$perl";
	    } else {
		$Perl = File::Spec->catfile(File::Spec->curdir(), $perl);
	    }