view release on metacpan or  search on metacpan

t/TestBC.pm  view on Meta::CPAN

    return $string if ord('^') == 94;   # ASCII, Latin1
    my $cp;
    if (ord('^') == 95) {    # EBCDIC 1047
        $cp = \$cp_1047;
    }
    elsif (ord('^') == 106) {   # EBCDIC POSIX-BC
        $cp = \$cp_bc;
    }
    elsif (ord('^') == 176)  {   # EBCDIC 037 */
        $cp = \$cp_0037;
    }
    else {
        die "Unknown native character set";
    }

    eval '$string =~ tr/' . $$cp . '/' . $straight . '/';
    return $string;
}

sub latin1_to_native($) {
    my $string = shift;

    return $string if ord('^') == 94;   # ASCII, Latin1
    my $cp;
    if (ord('^') == 95) {    # EBCDIC 1047
        $cp = \$cp_1047;
    }
    elsif (ord('^') == 106) {   # EBCDIC POSIX-BC
        $cp = \$cp_bc;
    }
    elsif (ord('^') == 176)  {   # EBCDIC 037 */
        $cp = \$cp_0037;
    }
    else {
        die "Unknown native character set";
    }

    eval '$string =~ tr/' . $straight . '/' . $$cp . '/';
    return $string;
}

sub ord_latin1_to_native {
    # given an input code point, return the platform's native
    # equivalent value.  Anything above latin1 is itself.

    my $ord = shift;
    return $ord if $ord > 255;
    return ord latin1_to_native(chr $ord);
}

sub ord_native_to_latin1 {
    # given an input platform code point, return the latin1 equivalent value.
    # Anything above latin1 is itself.

    my $ord = shift;
    return $ord if $ord > 255;
    return ord native_to_latin1(chr $ord);
}

sub _where {
    my @caller = caller($Level);
    return "at $caller[1] line $caller[2]";
}

# runperl - Runs a separate perl interpreter.
# Arguments :
#   switches => [ command-line switches ]
#   nolib    => 1 # don't use -I../lib (included by default)
#   prog     => one-liner (avoid quotes)
#   progs    => [ multi-liner (avoid quotes) ]
#   progfile => perl script
#   stdin    => string to feed the stdin
#   stderr   => redirect stderr to stdout
#   args     => [ command-line arguments to the perl program ]
#   verbose  => print the command line

my $is_mswin    = $^O eq 'MSWin32';
my $is_msvc     = $is_mswin and $Config{cc} eq 'cl' ? 1 : 0;
my $is_netware  = $^O eq 'NetWare';
my $is_macos    = $^O eq 'MacOS';
my $is_vms      = $^O eq 'VMS';
my $is_cygwin   = $^O eq 'cygwin';

sub _quote_args {
    my ($runperl, $args) = @_;

    foreach (@$args) {
	# In VMS protect with doublequotes because otherwise
	# DCL will lowercase -- unless already doublequoted.
        $_ = q(").$_.q(") if $is_vms && !/^\"/ && length($_) > 0;
	$$runperl .= ' ' . $_;
    }
}

sub _create_runperl { # Create the string to qx in runperl().
    my %args = @_;
    my $runperl = $^X =~ m/\s/ ? qq{"$^X"} : $^X;
    #- this allows, for example, to set PERL_RUNPERL_DEBUG=/usr/bin/valgrind
    if ($ENV{PERL_RUNPERL_DEBUG}) {
	$runperl = "$ENV{PERL_RUNPERL_DEBUG} $runperl";
    }
    unless ($args{nolib}) {
	if ($is_macos) {
	    $runperl .= ' -I::lib';
	    # Use UNIX style error messages instead of MPW style.
	    $runperl .= ' -MMac::err=unix' if $args{stderr};
	}
	else {
	    $runperl .= ' "-I../lib"'; # doublequotes because of VMS
	}
    }
    if ($args{switches}) {
	local $Level = 2;
	die "test.pl:runperl(): 'switches' must be an ARRAYREF " . _where()
	    unless ref $args{switches} eq "ARRAY";
	_quote_args(\$runperl, $args{switches});
    }
    if (defined $args{prog}) {
	die "test.pl:runperl(): both 'prog' and 'progs' cannot be used " . _where()
	    if defined $args{progs};
        $args{progs} = [$args{prog}]