X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/5693d826577600a198e0f93a41f0ca319f85a889..9e27fd7083290e0886c26e7c6c5e4a1e2cbceae3:/t/test.pl diff --git a/t/test.pl b/t/test.pl index 5584669..2bf429c 100644 --- a/t/test.pl +++ b/t/test.pl @@ -1,5 +1,7 @@ # -# t/test.pl - most of Test::More functionality without the fuss +# t/test.pl - most of Test::More functionality without the fuss, plus +# has mappings native_to_latin1 and latin1_to_native so that fewer tests +# on non ASCII-ish platforms need to be skipped # NOTE: @@ -20,10 +22,22 @@ $Level = 1; my $test = 1; my $planned; my $noplan; +my $Perl; # Safer version of $^X set by which_perl() $TODO = 0; $NO_ENDING = 0; +# Use this instead of print to avoid interference while testing globals. +sub _print { + local($\, $", $,) = (undef, ' ', ''); + print STDOUT @_; +} + +sub _print_stderr { + local($\, $", $,) = (undef, ' ', ''); + print STDERR @_; +} + sub plan { my $n; if (@_ == 1) { @@ -36,7 +50,7 @@ sub plan { my %plan = @_; $n = $plan{tests}; } - print STDOUT "1..$n\n" unless $noplan; + _print "1..$n\n" unless $noplan; $planned = $n; } @@ -44,10 +58,10 @@ END { my $ran = $test - 1; if (!$NO_ENDING) { if (defined $planned && $planned != $ran) { - print STDERR + _print_stderr "# Looks like you planned $planned tests but ran $ran.\n"; } elsif ($noplan) { - print "1..$ran\n"; + _print "1..$ran\n"; } } } @@ -58,9 +72,7 @@ sub _diag { return unless @_; my @mess = map { /^#/ ? "$_\n" : "# $_\n" } map { split /\n/ } @_; - my $fh = $TODO ? *STDOUT : *STDERR; - print $fh @mess; - + $TODO ? _print(@mess) : _print_stderr(@mess); } sub diag { @@ -69,9 +81,9 @@ sub diag { sub skip_all { if (@_) { - print STDOUT "1..0 # Skipped: @_\n"; + _print "1..0 # Skip @_\n"; } else { - print STDOUT "1..0\n"; + _print "1..0\n"; } exit(0); } @@ -89,8 +101,8 @@ sub _ok { $out = $pass ? "ok $test" : "not ok $test"; } - $out .= " # TODO $TODO" if $TODO; - print STDOUT "$out\n"; + $out = $out . " # TODO $TODO" if $TODO; + _print "$out\n"; unless ($pass) { _diag "# Failed $where\n"; @@ -143,13 +155,22 @@ sub display { my $y = ''; foreach my $c (unpack("U*", $x)) { if ($c > 255) { - $y .= sprintf "\\x{%x}", $c; + $y = $y . sprintf "\\x{%x}", $c; } elsif ($backslash_escape{$c}) { - $y .= $backslash_escape{$c}; + $y = $y . $backslash_escape{$c}; } else { my $z = chr $c; # Maybe we can get away with a literal... - $z = sprintf "\\%03o", $c if $z =~ /[[:^print:]]/; - $y .= $z; + if ($z =~ /[[:^print:]]/) { + + # Use octal for characters traditionally expressed as + # such: the low controls + if ($c <= 037) { + $z = sprintf "\\%03o", $c; + } else { + $z = sprintf "\\x{%x}", $c; + } + } + $y = $y . $z; } } $x = $y; @@ -173,8 +194,8 @@ sub is ($$@) { } unless ($pass) { - unshift(@mess, "# got "._q($got)."\n", - "# expected "._q($expected)."\n"); + unshift(@mess, "# got "._qq($got)."\n", + "# expected "._qq($expected)."\n"); } _ok($pass, _where(), $name, @mess); } @@ -192,7 +213,7 @@ sub isnt ($$@) { } unless( $pass ) { - unshift(@mess, "# it should not be "._q($got)."\n", + unshift(@mess, "# it should not be "._qq($got)."\n", "# but it is.\n"); } _ok($pass, _where(), $name, @mess); @@ -219,8 +240,8 @@ sub cmp_ok ($$$@) { if ($got eq $expected and $type !~ tr/a-z//) { unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n"; } - unshift(@mess, "# got "._q($got)."\n", - "# expected $type "._q($expected)."\n"); + unshift(@mess, "# got "._qq($got)."\n", + "# expected $type "._qq($expected)."\n"); } _ok($pass, _where(), $name, @mess); } @@ -256,8 +277,8 @@ sub within ($$$@) { if ($got eq $expected) { unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n"; } - unshift@mess, "# got "._q($got)."\n", - "# expected "._q($expected)." (within "._q($range).")\n"; + unshift@mess, "# got "._qq($got)."\n", + "# expected "._qq($expected)." (within "._qq($range).")\n"; } _ok($pass, _where(), $name, @mess); } @@ -274,7 +295,8 @@ sub like_yn ($$$@) { $pass = $got !~ /$expected/ if $flip; unless ($pass) { unshift(@mess, "# got '$got'\n", - "# expected /$expected/\n"); + $flip + ? "# expected !~ /$expected/\n" : "# expected /$expected/\n"); } local $Level = $Level + 1; _ok($pass, _where(), $name, @mess); @@ -305,7 +327,7 @@ sub skip { my $why = shift; my $n = @_ ? shift : 1; for (1..$n) { - print STDOUT "ok $test # skip: $why\n"; + _print "ok $test # skip $why\n"; $test = $test + 1; } local $^W = 0; @@ -317,7 +339,7 @@ sub todo_skip { my $n = @_ ? shift : 1; for (1..$n) { - print STDOUT "not ok $test # TODO & SKIP: $why\n"; + _print "not ok $test # TODO & SKIP $why\n"; $test = $test + 1; } local $^W = 0; @@ -344,12 +366,12 @@ sub eq_hash { $key = "" . $key; if (exists $orig->{$key}) { if ($orig->{$key} ne $value) { - print STDOUT "# key ", _qq($key), " was ", _qq($orig->{$key}), + _print "# key ", _qq($key), " was ", _qq($orig->{$key}), " now ", _qq($value), "\n"; $fail = 1; } } else { - print STDOUT "# key ", _qq($key), " is ", _qq($value), + _print "# key ", _qq($key), " is ", _qq($value), ", not in original.\n"; $fail = 1; } @@ -358,7 +380,7 @@ sub eq_hash { # Force a hash recompute if this perl's internals can cache the hash key. $_ = "" . $_; next if (exists $suspect->{$_}); - print STDOUT "# key ", _qq($_), " was ", _qq($orig->{$_}), " now missing.\n"; + _print "# key ", _qq($_), " was ", _qq($orig->{$_}), " now missing.\n"; $fail = 1; } !$fail; @@ -394,8 +416,8 @@ USE_OK my $is_mswin = $^O eq 'MSWin32'; 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) = @_; @@ -404,32 +426,29 @@ sub _quote_args { # In VMS protect with doublequotes because otherwise # DCL will lowercase -- unless already doublequoted. $_ = q(").$_.q(") if $is_vms && !/^\"/ && length($_) > 0; - $$runperl .= ' ' . $_; + $runperl = $runperl . ' ' . $_; } + return $runperl; } sub _create_runperl { # Create the string to qx in runperl(). my %args = @_; - my $runperl = $^X =~ m/\s/ ? qq{"$^X"} : $^X; + my $runperl = which_perl(); + if ($runperl =~ m/\s/) { + $runperl = qq{"$runperl"}; + } #- 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 - } + $runperl = $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}); + $runperl = _quote_args($runperl, $args{switches}); } if (defined $args{prog}) { die "test.pl:runperl(): both 'prog' and 'progs' cannot be used " . _where() @@ -441,14 +460,14 @@ sub _create_runperl { # Create the string to qx in runperl(). unless ref $args{progs} eq "ARRAY"; foreach my $prog (@{$args{progs}}) { if ($is_mswin || $is_netware || $is_vms) { - $runperl .= qq ( -e "$prog" ); + $runperl = $runperl . qq ( -e "$prog" ); } else { - $runperl .= qq ( -e '$prog' ); + $runperl = $runperl . qq ( -e '$prog' ); } } } elsif (defined $args{progfile}) { - $runperl .= qq( "$args{progfile}"); + $runperl = $runperl . qq( "$args{progfile}"); } else { # You probaby didn't want to be sucking in from the upstream stdin die "test.pl:runperl(): none of prog, progs, progfile, args, " @@ -463,36 +482,22 @@ sub _create_runperl { # Create the string to qx in runperl(). $args{stdin} =~ s/\r/\\r/g; if ($is_mswin || $is_netware || $is_vms) { - $runperl = qq{$^X -e "print qq(} . + $runperl = qq{$Perl -e "print qq(} . $args{stdin} . q{)" | } . $runperl; } - elsif ($is_macos) { - # MacOS can only do two processes under MPW at once; - # the test itself is one; we can't do two more, so - # write to temp file - my $stdin = qq{$^X -e 'print qq(} . $args{stdin} . qq{)' > teststdin; }; - if ($args{verbose}) { - my $stdindisplay = $stdin; - $stdindisplay =~ s/\n/\n\#/g; - print STDERR "# $stdindisplay\n"; - } - `$stdin`; - $runperl .= q{ < teststdin }; - } else { - $runperl = qq{$^X -e 'print qq(} . + $runperl = qq{$Perl -e 'print qq(} . $args{stdin} . q{)' | } . $runperl; } } if (defined $args{args}) { - _quote_args(\$runperl, $args{args}); + $runperl = _quote_args($runperl, $args{args}); } - $runperl .= ' 2>&1' if $args{stderr} && !$is_macos; - $runperl .= " \xB3 Dev:Null" if !$args{stderr} && $is_macos; + $runperl = $runperl . ' 2>&1' if $args{stderr}; if ($args{verbose}) { my $runperldisplay = $runperl; $runperldisplay =~ s/\n/\n\#/g; - print STDERR "# $runperldisplay\n"; + _print_stderr "# $runperldisplay\n"; } return $runperl; } @@ -512,23 +517,23 @@ sub runperl { # run a fresh perl, so we'll brute force launder everything for you my $sep; - eval "require Config; Config->import"; - if ($@) { + if (! eval 'require Config; 1') { warn "test.pl had problems loading Config: $@"; $sep = ':'; } else { - $sep = $Config{path_sep}; + $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 && ($ENV{'DCL$PATH'} =~ /(.*)/s); + 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 + join $sep, grep { $_ ne "" and $_ ne "." and -d $_ and ($is_mswin or $is_vms or !(stat && (stat _)[2]&0022)) } split quotemeta ($sep), $1; + $ENV{PATH} = $ENV{PATH} . "$sep/bin" if $is_cygwin; # Must have /bin under Cygwin $runperl =~ /(.*)/s; $runperl = $1; @@ -544,12 +549,11 @@ sub runperl { *run_perl = \&runperl; # Nice alias. sub DIE { - print STDERR "# @_\n"; + _print_stderr "# @_\n"; exit 1; } # A somewhat safer version of the sometimes wrong $^X. -my $Perl; sub which_perl { unless (defined $Perl) { $Perl = $^X; @@ -558,12 +562,11 @@ sub which_perl { return $Perl if $^O eq 'VMS'; my $exe; - eval "require Config; Config->import"; - if ($@) { + if (! eval 'require Config; 1') { warn "test.pl had problems loading Config: $@"; $exe = ''; } else { - $exe = $Config{_exe}; + $exe = $Config::Config{_exe}; } $exe = '' unless defined $exe; @@ -573,8 +576,7 @@ sub which_perl { if ($Perl =~ /^perl\Q$exe\E$/i) { my $perl = "perl$exe"; - eval "require File::Spec"; - if ($@) { + if (! eval 'require File::Spec; 1') { warn "test.pl had problems loading File::Spec: $@"; $Perl = "./$perl"; } else { @@ -586,7 +588,7 @@ sub which_perl { # the command. if ($Perl !~ /\Q$exe\E$/i) { - $Perl .= $exe; + $Perl = $Perl . $exe; } warn "which_perl: cannot find $Perl from $^X" unless -f $Perl; @@ -600,14 +602,41 @@ sub which_perl { sub unlink_all { foreach my $file (@_) { 1 while unlink $file; - print STDERR "# Couldn't unlink '$file': $!\n" if -f $file; + _print_stderr "# Couldn't unlink '$file': $!\n" if -f $file; } } +my %tmpfiles; +END { unlink_all keys %tmpfiles } + +# A regexp that matches the tempfile names +$::tempfile_regexp = 'tmp\d+[A-Z][A-Z]?'; + +# Avoid ++, avoid ranges, avoid split // +my @letters = qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z); +sub tempfile { + my $count = 0; + do { + my $temp = $count; + my $try = "tmp$$"; + do { + $try = $try . $letters[$temp % 26]; + $temp = int ($temp / 26); + } while $temp; + # Need to note all the file names we allocated, as a second request may + # come before the first is created. + if (!-e $try && !$tmpfiles{$try}) { + # We have a winner + $tmpfiles{$try} = 1; + return $try; + } + $count = $count + 1; + } while $count < 26 * 26; + die "Can't find temporary file name starting 'tmp$$'"; +} -my $tmpfile = "misctmp000"; -1 while -f ++$tmpfile; -END { unlink_all $tmpfile } +# This is the temporary file for _fresh_perl +my $tmpfile = tempfile(); # # _fresh_perl @@ -620,7 +649,14 @@ END { unlink_all $tmpfile } sub _fresh_perl { my($prog, $resolve, $runperl_args, $name) = @_; - $runperl_args ||= {}; + # Given the choice of the mis-parsable {} + # (we want an anon hash, but a borked lexer might think that it's a block) + # or relying on taking a reference to a lexical + # (\ might be mis-parsed, and the reference counting on the pad may go + # awry) + # it feels like the least-worse thing is to assume that auto-vivification + # works. At least, this is only going to be a run-time failure, so won't + # affect tests using this file but not this function. $runperl_args->{progfile} = $tmpfile; $runperl_args->{stderr} = 1; @@ -642,9 +678,9 @@ sub _fresh_perl { my $status = $?; # Clean up the results into something a bit more predictable. - $results =~ s/\n+$//; - $results =~ s/at\s+misctmp\d+\s+line/at - line/g; - $results =~ s/of\s+misctmp\d+\s+aborted/of - aborted/g; + $results =~ s/\n+$//; + $results =~ s/at\s+$::tempfile_regexp\s+line/at - line/g; + $results =~ s/of\s+$::tempfile_regexp\s+aborted/of - aborted/g; # bison says 'parse error' instead of 'syntax error', # various yaccs may or may not capitalize 'syntax'. @@ -669,7 +705,7 @@ sub _fresh_perl { # Use the first line of the program as a name if none was given unless( $name ) { ($first_line, $name) = $prog =~ /^((.{1,50}).*)/; - $name .= '...' if length $first_line > length $name; + $name = $name . '...' if length $first_line > length $name; } _ok($pass, _where(), "fresh_perl - $name"); @@ -683,6 +719,11 @@ sub _fresh_perl { sub fresh_perl_is { my($prog, $expected, $runperl_args, $name) = @_; + + # _fresh_perl() is going to clip the trailing newlines off the result. + # This will make it so the test author doesn't have to know that. + $expected =~ s/\n+$//; + local $Level = 2; _fresh_perl($prog, sub { @_ ? $_[0] eq $expected : $expected }, @@ -699,9 +740,7 @@ sub fresh_perl_like { my($prog, $expected, $runperl_args, $name) = @_; local $Level = 2; _fresh_perl($prog, - sub { @_ ? - $_[0] =~ (ref $expected ? $expected : /$expected/) : - $expected }, + sub { @_ ? $_[0] =~ $expected : $expected }, $runperl_args, $name); } @@ -767,4 +806,267 @@ WHOA _ok( !$diag, _where(), $name ); } +# Set a watchdog to timeout the entire test file +# NOTE: If the test file uses 'threads', then call the watchdog() function +# _AFTER_ the 'threads' module is loaded. +sub watchdog ($;$) +{ + my $timeout = shift; + my $method = shift || ""; + my $timeout_msg = 'Test process timed out - terminating'; + + # Valgrind slows perl way down so give it more time before dying. + $timeout *= 10 if $ENV{PERL_VALGRIND}; + + my $pid_to_kill = $$; # PID for this process + + if ($method eq "alarm") { + goto WATCHDOG_VIA_ALARM; + } + + # Don't use a watchdog process if 'threads' is loaded - + # use a watchdog thread instead + if (! $threads::threads) { + + # On Windows and VMS, try launching a watchdog process + # using system(1, ...) (see perlport.pod) + if (($^O eq 'MSWin32') || ($^O eq 'VMS')) { + # On Windows, try to get the 'real' PID + if ($^O eq 'MSWin32') { + eval { require Win32; }; + if (defined(&Win32::GetCurrentProcessId)) { + $pid_to_kill = Win32::GetCurrentProcessId(); + } + } + + # If we still have a fake PID, we can't use this method at all + return if ($pid_to_kill <= 0); + + # Launch watchdog process + my $watchdog; + eval { + local $SIG{'__WARN__'} = sub { + _diag("Watchdog warning: $_[0]"); + }; + my $sig = $^O eq 'VMS' ? 'TERM' : 'KILL'; + my $cmd = _create_runperl( prog => "sleep($timeout);" . + "warn qq/# $timeout_msg" . '\n/;' . + "kill($sig, $pid_to_kill);"); + $watchdog = system(1, $cmd); + }; + if ($@ || ($watchdog <= 0)) { + _diag('Failed to start watchdog'); + _diag($@) if $@; + undef($watchdog); + return; + } + + # Add END block to parent to terminate and + # clean up watchdog process + eval "END { local \$! = 0; local \$? = 0; + wait() if kill('KILL', $watchdog); };"; + return; + } + + # Try using fork() to generate a watchdog process + my $watchdog; + eval { $watchdog = fork() }; + if (defined($watchdog)) { + if ($watchdog) { # Parent process + # Add END block to parent to terminate and + # clean up watchdog process + eval "END { local \$! = 0; local \$? = 0; + wait() if kill('KILL', $watchdog); };"; + return; + } + + ### Watchdog process code + + # Load POSIX if available + eval { require POSIX; }; + + # Execute the timeout + sleep($timeout - 2) if ($timeout > 2); # Workaround for perlbug #49073 + sleep(2); + + # Kill test process if still running + if (kill(0, $pid_to_kill)) { + _diag($timeout_msg); + kill('KILL', $pid_to_kill); + } + + # Don't execute END block (added at beginning of this file) + $NO_ENDING = 1; + + # Terminate ourself (i.e., the watchdog) + POSIX::_exit(1) if (defined(&POSIX::_exit)); + exit(1); + } + + # fork() failed - fall through and try using a thread + } + + # Use a watchdog thread because either 'threads' is loaded, + # or fork() failed + if (eval 'require threads; 1') { + threads->create(sub { + # Load POSIX if available + eval { require POSIX; }; + + # Execute the timeout + my $time_left = $timeout; + do { + $time_left = $time_left - sleep($time_left); + } while ($time_left > 0); + + # Kill the parent (and ourself) + select(STDERR); $| = 1; + _diag($timeout_msg); + POSIX::_exit(1) if (defined(&POSIX::_exit)); + my $sig = $^O eq 'VMS' ? 'TERM' : 'KILL'; + kill($sig, $pid_to_kill); + })->detach(); + return; + } + + # If everything above fails, then just use an alarm timeout +WATCHDOG_VIA_ALARM: + if (eval { alarm($timeout); 1; }) { + # Load POSIX if available + eval { require POSIX; }; + + # Alarm handler will do the actual 'killing' + $SIG{'ALRM'} = sub { + select(STDERR); $| = 1; + _diag($timeout_msg); + POSIX::_exit(1) if (defined(&POSIX::_exit)); + my $sig = $^O eq 'VMS' ? 'TERM' : 'KILL'; + kill($sig, $pid_to_kill); + }; + } +} + +my $cp_0037 = # EBCDIC code page 0037 + '\x00\x01\x02\x03\x37\x2D\x2E\x2F\x16\x05\x25\x0B\x0C\x0D\x0E\x0F' . + '\x10\x11\x12\x13\x3C\x3D\x32\x26\x18\x19\x3F\x27\x1C\x1D\x1E\x1F' . + '\x40\x5A\x7F\x7B\x5B\x6C\x50\x7D\x4D\x5D\x5C\x4E\x6B\x60\x4B\x61' . + '\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\x7A\x5E\x4C\x7E\x6E\x6F' . + '\x7C\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xD1\xD2\xD3\xD4\xD5\xD6' . + '\xD7\xD8\xD9\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xBA\xE0\xBB\xB0\x6D' . + '\x79\x81\x82\x83\x84\x85\x86\x87\x88\x89\x91\x92\x93\x94\x95\x96' . + '\x97\x98\x99\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xC0\x4F\xD0\xA1\x07' . + '\x20\x21\x22\x23\x24\x15\x06\x17\x28\x29\x2A\x2B\x2C\x09\x0A\x1B' . + '\x30\x31\x1A\x33\x34\x35\x36\x08\x38\x39\x3A\x3B\x04\x14\x3E\xFF' . + '\x41\xAA\x4A\xB1\x9F\xB2\x6A\xB5\xBD\xB4\x9A\x8A\x5F\xCA\xAF\xBC' . + '\x90\x8F\xEA\xFA\xBE\xA0\xB6\xB3\x9D\xDA\x9B\x8B\xB7\xB8\xB9\xAB' . + '\x64\x65\x62\x66\x63\x67\x9E\x68\x74\x71\x72\x73\x78\x75\x76\x77' . + '\xAC\x69\xED\xEE\xEB\xEF\xEC\xBF\x80\xFD\xFE\xFB\xFC\xAD\xAE\x59' . + '\x44\x45\x42\x46\x43\x47\x9C\x48\x54\x51\x52\x53\x58\x55\x56\x57' . + '\x8C\x49\xCD\xCE\xCB\xCF\xCC\xE1\x70\xDD\xDE\xDB\xDC\x8D\x8E\xDF'; + +my $cp_1047 = # EBCDIC code page 1047 + '\x00\x01\x02\x03\x37\x2D\x2E\x2F\x16\x05\x15\x0B\x0C\x0D\x0E\x0F' . + '\x10\x11\x12\x13\x3C\x3D\x32\x26\x18\x19\x3F\x27\x1C\x1D\x1E\x1F' . + '\x40\x5A\x7F\x7B\x5B\x6C\x50\x7D\x4D\x5D\x5C\x4E\x6B\x60\x4B\x61' . + '\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\x7A\x5E\x4C\x7E\x6E\x6F' . + '\x7C\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xD1\xD2\xD3\xD4\xD5\xD6' . + '\xD7\xD8\xD9\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xAD\xE0\xBD\x5F\x6D' . + '\x79\x81\x82\x83\x84\x85\x86\x87\x88\x89\x91\x92\x93\x94\x95\x96' . + '\x97\x98\x99\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xC0\x4F\xD0\xA1\x07' . + '\x20\x21\x22\x23\x24\x25\x06\x17\x28\x29\x2A\x2B\x2C\x09\x0A\x1B' . + '\x30\x31\x1A\x33\x34\x35\x36\x08\x38\x39\x3A\x3B\x04\x14\x3E\xFF' . + '\x41\xAA\x4A\xB1\x9F\xB2\x6A\xB5\xBB\xB4\x9A\x8A\xB0\xCA\xAF\xBC' . + '\x90\x8F\xEA\xFA\xBE\xA0\xB6\xB3\x9D\xDA\x9B\x8B\xB7\xB8\xB9\xAB' . + '\x64\x65\x62\x66\x63\x67\x9E\x68\x74\x71\x72\x73\x78\x75\x76\x77' . + '\xAC\x69\xED\xEE\xEB\xEF\xEC\xBF\x80\xFD\xFE\xFB\xFC\xBA\xAE\x59' . + '\x44\x45\x42\x46\x43\x47\x9C\x48\x54\x51\x52\x53\x58\x55\x56\x57' . + '\x8C\x49\xCD\xCE\xCB\xCF\xCC\xE1\x70\xDD\xDE\xDB\xDC\x8D\x8E\xDF'; + +my $cp_bc = # EBCDIC code page POSiX-BC + '\x00\x01\x02\x03\x37\x2D\x2E\x2F\x16\x05\x15\x0B\x0C\x0D\x0E\x0F' . + '\x10\x11\x12\x13\x3C\x3D\x32\x26\x18\x19\x3F\x27\x1C\x1D\x1E\x1F' . + '\x40\x5A\x7F\x7B\x5B\x6C\x50\x7D\x4D\x5D\x5C\x4E\x6B\x60\x4B\x61' . + '\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\x7A\x5E\x4C\x7E\x6E\x6F' . + '\x7C\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xD1\xD2\xD3\xD4\xD5\xD6' . + '\xD7\xD8\xD9\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xBB\xBC\xBD\x6A\x6D' . + '\x4A\x81\x82\x83\x84\x85\x86\x87\x88\x89\x91\x92\x93\x94\x95\x96' . + '\x97\x98\x99\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xFB\x4F\xFD\xFF\x07' . + '\x20\x21\x22\x23\x24\x25\x06\x17\x28\x29\x2A\x2B\x2C\x09\x0A\x1B' . + '\x30\x31\x1A\x33\x34\x35\x36\x08\x38\x39\x3A\x3B\x04\x14\x3E\x5F' . + '\x41\xAA\xB0\xB1\x9F\xB2\xD0\xB5\x79\xB4\x9A\x8A\xBA\xCA\xAF\xA1' . + '\x90\x8F\xEA\xFA\xBE\xA0\xB6\xB3\x9D\xDA\x9B\x8B\xB7\xB8\xB9\xAB' . + '\x64\x65\x62\x66\x63\x67\x9E\x68\x74\x71\x72\x73\x78\x75\x76\x77' . + '\xAC\x69\xED\xEE\xEB\xEF\xEC\xBF\x80\xE0\xFE\xDD\xFC\xAD\xAE\x59' . + '\x44\x45\x42\x46\x43\x47\x9C\x48\x54\x51\x52\x53\x58\x55\x56\x57' . + '\x8C\x49\xCD\xCE\xCB\xCF\xCC\xE1\x70\xC0\xDE\xDB\xDC\x8D\x8E\xDF'; + +my $straight = # Avoid ranges + '\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0A\x0B\x0C\x0D\x0E\x0F' . + '\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1A\x1B\x1C\x1D\x1E\x1F' . + '\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2A\x2B\x2C\x2D\x2E\x2F' . + '\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3A\x3B\x3C\x3D\x3E\x3F' . + '\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4A\x4B\x4C\x4D\x4E\x4F' . + '\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5A\x5B\x5C\x5D\x5E\x5F' . + '\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6A\x6B\x6C\x6D\x6E\x6F' . + '\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7A\x7B\x7C\x7D\x7E\x7F' . + '\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8A\x8B\x8C\x8D\x8E\x8F' . + '\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9A\x9B\x9C\x9D\x9E\x9F' . + '\xA0\xA1\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xAA\xAB\xAC\xAD\xAE\xAF' . + '\xB0\xB1\xB2\xB3\xB4\xB5\xB6\xB7\xB8\xB9\xBA\xBB\xBC\xBD\xBE\xBF' . + '\xC0\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xCA\xCB\xCC\xCD\xCE\xCF' . + '\xD0\xD1\xD2\xD3\xD4\xD5\xD6\xD7\xD8\xD9\xDA\xDB\xDC\xDD\xDE\xDF' . + '\xE0\xE1\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xEA\xEB\xEC\xED\xEE\xEF' . + '\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\xFA\xFB\xFC\xFD\xFE\xFF'; + +# The following 2 functions allow tests to work on both EBCDIC and +# ASCII-ish platforms. They convert string scalars between the native +# character set and the set of 256 characters which is usually called +# Latin1. +# +# These routines don't work on UTF-EBCDIC and UTF-8. + +sub native_to_latin1($) { + 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/' . $$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; +} + 1;