diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Test.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Test.pm | 66 |
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 |