#
-# 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
+# t/test.pl - most of Test::More functionality without the fuss
# NOTE:
#
-# Increment ($x++) has a certain amount of cleverness for things like
+# Do not rely on features found only in more modern Perls here, as some CPAN
+# distributions copy this file and must operate on older Perls. Similarly, keep
+# things, simple as this may be run under fairly broken circumstances. For
+# example, increment ($x++) has a certain amount of cleverness for things like
#
# $x = 'zz';
# $x++; # $x eq 'aaa';
#
-# stands more chance of breaking than just a simple
+# This stands more chance of breaking than just a simple
#
# $x = $x + 1
#
}
} else {
my %plan = @_;
+ $plan{skip_all} and skip_all($plan{skip_all});
$n = $plan{tests};
}
_print "1..$n\n" unless $noplan;
return !defined &DynaLoader::boot_DynaLoader;
}
+sub set_up_inc {
+ # Don’t clobber @INC under miniperl
+ @INC = () unless is_miniperl;
+ unshift @INC, @_;
+}
+
sub _comment {
return map { /^#/ ? "$_\n" : "# $_\n" }
map { split /\n/ } @_;
}
}
+sub skip_all_without_unicode_tables { # (but only under miniperl)
+ if (is_miniperl()) {
+ skip_all_if_miniperl("Unicode tables not built yet")
+ unless eval 'require "unicore/Heavy.pl"';
+ }
+}
+
sub find_git_or_skip {
my ($source_dir, $reason);
if (-d '.git') {
return defined $x ? '"' . display ($x) . '"' : 'undef';
};
+# Support pre-5.10 Perls, for the benefit of CPAN dists that copy this file.
+# Note that chr(90) exists in both ASCII ("Z") and EBCDIC ("!").
+my $chars_template = defined(eval { pack "W*", 90 }) ? "W*" : "U*";
+eval 'sub re::is_regexp { ref($_[0]) eq "Regexp" }'
+ if !defined &re::is_regexp;
+
# keys are the codes \n etc map to, values are 2 char strings such as \n
my %backslash_escape;
foreach my $x (split //, 'nrtfa\\\'"') {
foreach my $x (@_) {
if (defined $x and not ref $x) {
my $y = '';
- foreach my $c (unpack("U*", $x)) {
+ foreach my $c (unpack($chars_template, $x)) {
if ($c > 255) {
$y = $y . sprintf "\\x{%x}", $c;
} elsif ($backslash_escape{$c}) {
$y = $y . $backslash_escape{$c};
} else {
my $z = chr $c; # Maybe we can get away with a literal...
- if ($z =~ /[[:^print:]]/) {
- # Use octal for characters traditionally expressed as
- # such: the low controls, which on EBCDIC aren't
- # necessarily the same ones as on ASCII platforms, but
- # are small ordinals, nonetheless
- if ($c <= 037) {
+ if ($z !~ /[^[:^print:][:^ascii:]]/) {
+ # The pattern above is equivalent (by de Morgan's
+ # laws) to:
+ # $z !~ /(?[ [:print:] & [:ascii:] ])/
+ # or, $z is not an ascii printable character
+
+ # Use octal for characters with small ordinals that
+ # are traditionally expressed as octal: the controls
+ # below space, which on EBCDIC are almost all the
+ # controls, but on ASCII don't include DEL nor the C1
+ # controls.
+ if ($c < ord " ") {
$z = sprintf "\\%03o", $c;
} else {
$z = sprintf "\\x{%x}", $c;
sub like_yn ($$$@) {
my ($flip, undef, $expected, $name, @mess) = @_;
+
+ # We just accept like(..., qr/.../), not like(..., '...'), and
+ # definitely not like(..., '/.../') like
+ # Test::Builder::maybe_regex() does.
+ unless (re::is_regexp($expected)) {
+ die "PANIC: The value '$expected' isn't a regexp. The like() function needs a qr// pattern, not a string";
+ }
+
my $pass;
$pass = $_[1] =~ /$expected/ if !$flip;
$pass = $_[1] !~ /$expected/ if $flip;
+ my $display_got = $_[1];
+ $display_got = display($display_got);
+ my $display_expected = $expected;
+ $display_expected = display($display_expected);
unless ($pass) {
- unshift(@mess, "# got '$_[1]'\n",
+ unshift(@mess, "# got '$display_got'\n",
$flip
- ? "# expected !~ /$expected/\n" : "# expected /$expected/\n");
+ ? "# expected !~ /$display_expected/\n"
+ : "# expected /$display_expected/\n");
}
local $Level = $Level + 1;
_ok($pass, _where(), $name, @mess);
# be compatible with Test::More::skip().
sub skip {
my $why = shift;
- my $n = @_ ? shift : 1;
+ my $n = @_ ? shift : 1;
+ my $bad_swap;
+ my $both_zero;
+ {
+ local $^W = 0;
+ $bad_swap = $why > 0 && $n == 0;
+ $both_zero = $why == 0 && $n == 0;
+ }
+ if ($bad_swap || $both_zero || @_) {
+ my $arg = "'$why', '$n'";
+ if (@_) {
+ $arg .= join(", ", '', map { qq['$_'] } @_);
+ }
+ die qq[$0: expected skip(why, count), got skip($arg)\n];
+ }
for (1..$n) {
_print "ok $test # skip $why\n";
$test = $test + 1;
}
sub skip_without_dynamic_extension {
- my ($extension) = @_;
- skip("no dynamic loading on miniperl, no $extension") if is_miniperl();
- return if &_have_dynamic_extension;
- skip("$extension was not built");
+ my $extension = shift;
+ skip("no dynamic loading on miniperl, no extension $extension", @_)
+ if is_miniperl();
+ return if &_have_dynamic_extension($extension);
+ skip("extension $extension was not built", @_);
}
sub todo_skip {
if (defined $args{prog}) {
die "test.pl:runperl(): both 'prog' and 'progs' cannot be used " . _where()
if defined $args{progs};
- $args{progs} = [$args{prog}]
+ $args{progs} = [split /\n/, $args{prog}, -1]
}
if (defined $args{progs}) {
die "test.pl:runperl(): 'progs' must be an ARRAYREF " . _where()
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';
return $count;
}
-# This is the temporary file for _fresh_perl
+# This is the temporary file for fresh_perl
my $tmpfile = tempfile();
-sub _fresh_perl {
- my($prog, $action, $expect, $runperl_args, $name) = @_;
+sub fresh_perl {
+ my($prog, $runperl_args) = @_;
+
+ # Run 'runperl' with the complete perl program contained in '$prog', and
+ # arguments in the hash referred to by '$runperl_args'. The results are
+ # returned, with $? set to the exit code. Unless overridden, stderr is
+ # redirected to stdout.
+
+ die sprintf "Third argument to fresh_perl_.* must be hashref of args to fresh_perl (or {})"
+ unless !(defined $runperl_args) || ref($runperl_args) eq 'HASH';
# Given the choice of the mis-parsable {}
# (we want an anon hash, but a borked lexer might think that it's a block)
close TEST or die "Cannot close $tmpfile: $!";
my $results = runperl(%$runperl_args);
- my $status = $?;
+ my $status = $?; # Not necessary to save this, but it makes it clear to
+ # future maintainers.
# Clean up the results into something a bit more predictable.
$results =~ s/\n+$//;
$results =~ s/\n\n/\n/g;
}
+ $? = $status;
+ return $results;
+}
+
+
+sub _fresh_perl {
+ my($prog, $action, $expect, $runperl_args, $name) = @_;
+
+ my $results = fresh_perl($prog, $runperl_args);
+ my $status = $?;
+
# Use the first line of the program as a name if none was given
unless( $name ) {
($first_line, $name) = $prog =~ /^((.{1,50}).*)/;
# Written so as to count as one test
local $Level = $Level + 1;
if( ref $class ) {
- ok( 0, "$class is a refrence, not a class name" );
+ ok( 0, "$class is a reference, not a class name" );
}
else {
isa_ok($class, $isa, $class_name);
_diag("Watchdog warning: $_[0]");
};
my $sig = $is_vms ? 'TERM' : 'KILL';
- my $cmd = _create_runperl( prog => "sleep($timeout);" .
- "warn qq/# $timeout_msg" . '\n/;' .
- "kill($sig, $pid_to_kill);");
- $watchdog = system(1, $cmd);
+ my $prog = "sleep($timeout);" .
+ "warn qq/# $timeout_msg" . '\n/;' .
+ "kill(q/$sig/, $pid_to_kill);";
+
+ # On Windows use the indirect object plus LIST form to guarantee
+ # that perl is launched directly rather than via the shell (see
+ # perlfunc.pod), and ensure that the LIST has multiple elements
+ # since the indirect object plus COMMANDSTRING form seems to
+ # hang (see perl #121283). Don't do this on VMS, which doesn't
+ # support the LIST form at all.
+ if ($is_mswin) {
+ my $runperl = which_perl();
+ if ($runperl =~ m/\s/) {
+ $runperl = qq{"$runperl"};
+ }
+ $watchdog = system({ $runperl } 1, $runperl, '-e', $prog);
+ }
+ else {
+ my $cmd = _create_runperl(prog => $prog);
+ $watchdog = system(1, $cmd);
+ }
};
if ($@ || ($watchdog <= 0)) {
_diag('Failed to start watchdog');
# Add END block to parent to terminate and
# clean up watchdog process
- # Win32 watchdog is launched by cmd.exe shell, so use process group
- # kill, otherwise the watchdog is never killed and harness waits
- # every time for the timeout, #121395
- eval( $is_mswin ?
- "END { local \$! = 0; local \$? = 0;
- wait() if kill('-KILL', $watchdog); };"
- : "END { local \$! = 0; local \$? = 0;
+ eval("END { local \$! = 0; local \$? = 0;
wait() if kill('KILL', $watchdog); };");
return;
}
}
}
-# 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.
-
-sub native_to_latin1($) {
- my $string = shift;
-
- return $string if $::IS_ASCII;
- my $output = "";
- for my $i (0 .. length($string) - 1) {
- $output .= chr(ord_native_to_latin1(ord(substr($string, $i, 1))));
- }
- # Preserve utf8ness of input onto the output, even if it didn't need to be
- # utf8
- utf8::upgrade($output) if utf8::is_utf8($string);
-
- return $output;
-}
-
-sub latin1_to_native($) {
- my $string = shift;
-
- return $string if $::IS_ASCII;
- my $output = "";
- for my $i (0 .. length($string) - 1) {
- $output .= chr(ord_latin1_to_native(ord(substr($string, $i, 1))));
- }
- # Preserve utf8ness of input onto the output, even if it didn't need to be
- # utf8
- utf8::upgrade($output) if utf8::is_utf8($string);
-
- return $output;
-}
-
-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 $::IS_ASCII;
- return utf8::unicode_to_native($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('^') == 94; # ASCII, Latin1
- return utf8::native_to_unicode($ord);
-}
-
1;