summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Test.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Test.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Test.pm66
1 files changed, 49 insertions, 17 deletions
diff --git a/Master/tlpkg/tlperl/lib/Test.pm b/Master/tlpkg/tlperl/lib/Test.pm
index 108bc10a167..3350517e649 100644
--- a/Master/tlpkg/tlperl/lib/Test.pm
+++ b/Master/tlpkg/tlperl/lib/Test.pm
@@ -20,7 +20,7 @@ sub _reset_globals {
$planned = 0;
}
-$VERSION = '1.26';
+$VERSION = '1.28_01';
require Exporter;
@ISA=('Exporter');
@@ -239,9 +239,31 @@ sub _quote {
$str =~ s/\n/\\n/g;
$str =~ s/\r/\\r/g;
$str =~ s/\t/\\t/g;
- $str =~ s/([\0-\037])(?!\d)/sprintf('\\%o',ord($1))/eg;
- $str =~ s/([\0-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg;
- $str =~ s/([^\0-\176])/sprintf('\\x{%X}',ord($1))/eg;
+ if (defined $^V && $^V ge v5.6) {
+ $str =~ s/([[:cntrl:]])(?!\d)/sprintf('\\%o',ord($1))/eg;
+ $str =~ s/([[:^print:]])/sprintf('\\x%02X',ord($1))/eg;
+ $str =~ s/([[:^ascii:]])/sprintf('\\x{%X}',ord($1))/eg;
+ }
+ elsif (ord("A") == 65) {
+ $str =~ s/([\0-\037])(?!\d)/sprintf('\\%o',ord($1))/eg;
+ $str =~ s/([\0-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg;
+ $str =~ s/([^\0-\176])/sprintf('\\x{%X}',ord($1))/eg;
+ }
+ else { # Assuming EBCDIC on this ancient Perl
+
+ # The controls except for one are 0-\077, so almost all controls on
+ # EBCDIC platforms will be expressed in octal, instead of just the C0
+ # ones.
+ $str =~ s/([\0-\077])(?!\d)/sprintf('\\%o',ord($1))/eg;
+ $str =~ s/([\0-\077])/sprintf('\\x%02X',ord($1))/eg;
+
+ $str =~ s/([^\0-\xFF])/sprintf('\\x{%X}',ord($1))/eg;
+
+ # What remains to be escaped are the non-ASCII-range characters,
+ # including the one control that isn't in the 0-077 range.
+ # (We don't escape further any ASCII printables.)
+ $str =~ s<[^ !"\$\%#'()*+,\-./0123456789:;\<=\>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz{|}~]><sprintf('\\x%02X',ord($1))>eg;
+ }
#if( $_[1] ) {
# substr( $str , 218-3 ) = "..."
# if length($str) >= 218 and !$ENV{PERL_TEST_NO_TRUNC};
@@ -273,14 +295,16 @@ the test fails. Examples:
ok( $foo =~ /bar/ ); # ok if $foo contains 'bar'
ok( baz($x + $y) eq 'Armondo' ); # ok if baz($x + $y) returns
# 'Armondo'
- ok( @a == @b ); # ok if @a and @b are the same length
+ ok( @a == @b ); # ok if @a and @b are the same
+ # length
The expression is evaluated in scalar context. So the following will
work:
- ok( @stuff ); # ok if @stuff has any elements
- ok( !grep !defined $_, @stuff ); # ok if everything in @stuff is
- # defined.
+ ok( @stuff ); # ok if @stuff has any
+ # elements
+ ok( !grep !defined $_, @stuff ); # ok if everything in @stuff
+ # is defined.
A special case is if the expression is a subroutine reference (in either
C<sub {...}> syntax or C<\&foo> syntax). In
@@ -437,23 +461,24 @@ sub _complain {
my $diag = $$detail{diagnostic};
$diag =~ s/\n/\n#/g if defined $diag;
+ my $out = $$detail{todo} ? $TESTOUT : $TESTERR;
$$detail{context} .= ' *TODO*' if $$detail{todo};
if (!$$detail{compare}) {
if (!$diag) {
- print $TESTERR "# Failed test $ntest in $$detail{context}\n";
+ print $out "# Failed test $ntest in $$detail{context}\n";
} else {
- print $TESTERR "# Failed test $ntest in $$detail{context}: $diag\n";
+ print $out "# Failed test $ntest in $$detail{context}: $diag\n";
}
} else {
my $prefix = "Test $ntest";
- print $TESTERR "# $prefix got: " . _quote($result) .
+ print $out "# $prefix got: " . _quote($result) .
" ($$detail{context})\n";
$prefix = ' ' x (length($prefix) - 5);
my $expected_quoted = (defined $$detail{regex})
? 'qr{'.($$detail{regex}).'}' : _quote($expected);
- print $TESTERR "# $prefix Expected: $expected_quoted",
+ print $out "# $prefix Expected: $expected_quoted",
$diag ? " ($diag)" : (), "\n";
_diff_complain( $result, $expected, $detail, $prefix )
@@ -461,7 +486,7 @@ sub _complain {
}
if(defined $Program_Lines{ $$detail{file} }[ $$detail{line} ]) {
- print $TESTERR
+ print $out
"# $$detail{file} line $$detail{line} is: $Program_Lines{ $$detail{file} }[ $$detail{line} ]\n"
if $Program_Lines{ $$detail{file} }[ $$detail{line} ]
=~ m/[^\s\#\(\)\{\}\[\]\;]/; # Otherwise it's uninformative
@@ -480,7 +505,12 @@ sub _diff_complain {
my($result, $expected, $detail, $prefix) = @_;
return _diff_complain_external(@_) if $ENV{PERL_TEST_DIFF};
return _diff_complain_algdiff(@_)
- if eval { require Algorithm::Diff; Algorithm::Diff->VERSION(1.15); 1; };
+ if eval {
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
+ require Algorithm::Diff; Algorithm::Diff->VERSION(1.15);
+ 1;
+ };
$told_about_diff++ or print $TESTERR <<"EOT";
# $prefix (Install the Algorithm::Diff module to have differences in multiline
@@ -634,7 +664,8 @@ Example usage:
my $if_MSWin =
$^O =~ m/MSWin/ ? 'Skip if under MSWin' : '';
- # A test to be skipped if under MSWin (i.e., run except under MSWin)
+ # A test to be skipped if under MSWin (i.e., run except under
+ # MSWin)
skip($if_MSWin, thing($foo), thing($bar) );
Or, going the other way:
@@ -642,7 +673,8 @@ Or, going the other way:
my $unless_MSWin =
$^O =~ m/MSWin/ ? '' : 'Skip unless under MSWin';
- # A test to be skipped unless under MSWin (i.e., run only under MSWin)
+ # A test to be skipped unless under MSWin (i.e., run only under
+ # MSWin)
skip($unless_MSWin, thing($foo), thing($bar) );
The tricky thing to remember is that the first parameter is true if
@@ -931,7 +963,7 @@ L<Test::Builder> for building your own testing library.
L<Test::Unit> is an interesting XUnit-style testing library.
-L<Test::Inline> and L<SelfTest> let you embed tests in code.
+L<Test::Inline> lets you embed tests in code.
=head1 AUTHOR